Bringing data from other workbooks - goal not accomplished in nested if - vba
I have this code in which I am bringing data from several workbooks into one. The data of each workbook needs to be added into a specific range depending on the source. To do this I nested some IFs with the partial name of the file as condition and giving the action of sending the values to the desired range, but when I run the code it only opens all the workbooks without performing any action. I already did some research and did not find anything to help me with my problem
Sub Update_Database()
Dim directory As String
Dim fileName As String
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
directory = .SelectedItems(1)
Err.Clear
End With
fileName = Dir(directory & "\", vbReadOnly)
Dim mwb As Workbook
Set mwb = Workbooks("OEE_Database_Final.xlsm")
Do While fileName <> ""
On Error GoTo ProcExit
With Workbooks.Open(fileName:=directory & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
If (fileName = "NOM*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O9:Z290").Value = mwb.Sheets("Database").Range("O9:Z290")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "SZE*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O291:Z537").Value = mwb.Sheets("Database").Range("O291:Z537")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "VEC*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O538:Z600").Value = mwb.Sheets("Database").Range("O538:Z600")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "KAY*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O601:Z809").Value = mwb.Sheets("Database").Range("O601:Z809")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "BBL*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O810:Z952").Value = mwb.Sheets("Database").Range("O810:Z952")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "POG*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O953:Z1037").Value = mwb.Sheets("Database").Range("O953:Z1037")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "SC1*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1038:Z1159").Value = mwb.Sheets("Database").Range("O1038:Z1159")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "SC2*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1160:Z1200").Value = mwb.Sheets("Database").Range("O1160:Z1200")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "SLP*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1201:Z1263").Value = mwb.Sheets("Database").Range("O1201:Z1263")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "UIT*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1264:Z1348").Value = mwb.Sheets("Database").Range("O1264:Z1348")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "ANE*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1349:Z1823").Value = mwb.Sheets("Database").Range("O1349:Z1823")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "HAL*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1824:Z2077").Value = mwb.Sheets("Database").Range("O1824:Z2077")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "SHX*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2078:Z2242").Value = mwb.Sheets("Database").Range("O2078:Z2242")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "BAY*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2243:Z2415").Value = mwb.Sheets("Database").Range("O2243:Z2415")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "TAM*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2416:Z2522").Value = mwb.Sheets("Database").Range("O2416:Z2522")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "PUC*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2523:Z2607").Value = mwb.Sheets("Database").Range("O2523:Z2607")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "JOF*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2608:Z2648").Value = mwb.Sheets("Database").Range("O2608:Z2648")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "MAV*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2649:Z2945").Value = mwb.Sheets("Database").Range("O2649:Z2945")
ActiveWorkbook.Close SaveChanges:=False
End If
End With
fileName = Dir
Loop
Application.ScreenUpdating = True
ProcExit:
Exit Sub
End Sub
You can "cheat" a little to get away with Select Case.
In order to use the Like with Select, you use Select Case True and then nest your scenraios using Like and wild card *.
code
With Workbooks.Open(Filename:=directory & "\" & Filename, UpdateLinks:=False, ReadOnly:=True)
Select Case True
Case Filename Like "NOM*.xlsx"
Case Filename Like "SZE*.xlsx"
Case Filename Like "VEC*.xlsx"
Case Filename Like "KAY*.xlsx"
Case Filename Like "BBL*.xlsx"
' put all other scenarios down here....
End Select
End With
Note: if all your files you are trying t check are excel files, so you don't need to add the .xlsx extension, just use NOM*, SZE*, etc.
Given the snippet
With Workbooks.Open(fileName:=directory & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
If (fileName = "NOM*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O9:Z290").Value = mwb.Sheets("Database").Range("O9:Z290")
ActiveWorkbook.Close SaveChanges:=False
End If
End With
you're opening a file, writing some values from mbw.Sheets("Database") to it and then close the just modified file without saving.
From your comment it seems your intention is to do the opposite:
Dim mwb As Workbook
Set mwb = Workbooks("OEE_Database_Final.xlsm")
Dim Ws As Worksheet
Set Ws = mwb.Sheets("Database")
Do While Filename <> ""
On Error GoTo ProcExit
With Workbooks.Open(Filename:=directory & "\" & Filename, UpdateLinks:=False, ReadOnly:=True)
Select Case True
Case Filename Like "NOM*.xlsx"
Ws.Range("O9:Z290").Value = .Sheets("Database").Range("O9:Z290").Value
.Close SaveChanges:=False
Case Filename Like "SZE*.xlsx"
' Code for this case
' Other cases...
Case Else
' Put code here that is executed if none of the previous names has been matched
' or remove 'Case Else' if you don't want anything to happen then
End Select
End With
Filename = Dir
Loop
Some things to note:
I've implemented the suggestion from Shai Rado's answer to make use of the Like operator in a Select Case structure
I've assigned a new Worksheet variable as such Set Ws = mwb.Sheets("Database") - this shortens the lines and makes it easier to refer to a different sheet, should requirements change (one change as opposed to ~20 changes)
The With block now is actually taken advantage of. When you do With Workbooks.Open, VBA provides you with an implicit reference to that workbook. So there is no need to refer to ActiveWorkbook. A simple . is enough. Also it removes that brittle dependency on having the right workbook active at the right time. (Imagine what happens if for whatever reason the ActiveWorkbook changes half-way through your macro... Not a likely scenario, I'll give you that.)
Related
Excel VBA - Running a Macro against all files in a folder [duplicate]
I have a folder where I receive 1000+ excel files on daily bases they all are same format and structure. What I want to do is run a macro on all 100+ files on daily bases ? Is there way to automate this ? So I can keep running that same macro on 1000+ files daily.
Assuming that you put your files in "Files" directory relative to your master workbook your code might look like this:
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
In this example DoWork() is your macro that you apply to all of your files. Make sure that you do all your processing in your macro is always in the context of the wb (currently opened workbook).
Disclaimer: all possible error handling skipped for brevity.
A part of the question might be how do I run this on 1000 files?... Do I have to add this macro to all 1000 workbooks? One way to do this is to add your macro's centrally to the file PERSONAL.XLSB (sometimes the extension might be different). This file will be loaded in the background every time you start Excel and makes your macro's available at any time. Initially the PERSONAL.XLSB file will NOT be there. To automatically create this file, just start recording a "dummy" macro (with the record button on the left-bottom of a spreadsheet) and select "Personal Macro Workbook" to store it in. After recording your macro, you can open the VBA editor with Alt+F11 and you will see the PERSONAL.XLSB file with the "dummy" recorded macro. I use this file to store loads of general macro's which are always available, independent of which .xlsx file I have open. I have added these macro's to my own menu ribbon. One disadvantage of this common macro file is that if you launch more than one instance of Excel, you will get an error message that the PERSONAL.XLSB file is already in use by Excel instance Nr. 1. This is no problem as long as you do not add new macro's at this moment.
Thank you very much for this
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "C:\Users\jkatanan\Desktop\20170206Glidepath\V37\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
BSAQmacro wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\C:\Users\20098323\Desktop\EXCL\"
Filename = Dir(Pathname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
While running this code its showing bad file name or number.
i have stored my all file in ("\C:\Users\20098323\Desktop\EXCL\") EXCL folder
Instead of passing the values to DoWork one can also run the jobs in Processfiles(). Sub ProcessFiles() Dim Filename, Pathname As String Dim wb1 As Workbook Dim wb2 As Workbook Dim Sheet As Worksheet Dim PasteStart As Range Dim Counter As Integer Set wb1 = ActiveWorkbook Set PasteStart = [RRimport!A1] Pathname = ActiveWorkbook.Path & "\For Macro to run\" Filename = Dir(Pathname & "*.xls") Do While Filename <> "" Set wb2 = Workbooks.Open(Pathname & Filename) For Each Sheet In wb2.Sheets With Sheet.UsedRange .Copy PasteStart Set PasteStart = PasteStart.Offset(.Rows.Count) End With Next Sheet wb2.Close Filename = Dir() Loop End Sub
This isn't an exact answer to the question, since I was just trying to run a single script on any file that I opened and couldn't get that to work, but I thought this might help others like me. It worked once I moved the code into a Module in the Visual Basic for Applications dialog box (go to "Insert" then "Module"). Once I added my VBA code to a module, I was able to open any other file in Excel (even a CSV file) and go to Macros, and run the Macro from the other file (that contains the Module with the code) on the file that I had open.
Thanks Peterm!!
Actually, I did my macro using exactly the same code you posted (process_fiels and dowork).
It worked brilliant!! (before my question)
Each of my 1000 workbooks has 84 worksheets. My own macro (which finally works!) splits each workbook into 85 different files (the original + a short version of each worksheet saved as an individual file).
That leaves me with 1000 files + 1000x85 in the same folder, and that would be really hard to sort out.
What I really need is for Process_Files to take the first file, create a folder with the name of the first file, move the first file to the folder with ist name, then run my macro (in the folder named after the first file in the newly created folder...), go back and take the second file, create a folder with the name of the second file, move the second file to the folder with ist name, then run my macro (in the folder named after the second file in the newly created folder...), etc...
At the end, I should have moved all files into folders with the same name as the files, and the contents of the original \Files\ folder would be 1000 folders with the name of the original files, containgin the original files + 84 files which my own macro already does.
Maybe it is easier with the code:
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
(Here, it should read the file name, create a folder with the file name, move the file into this newly created folder)
Set wb = Workbooks.Open(Pathname & Filename) <- open file, just as is.
DoWork wb <- do my macro,just as is
wb.Close SaveChanges:=False <- not save, to keep the original file
(go back to the original \Files\ folder)
Filename = Dir() <- Next file, just as is
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
MyMacro
End With
End Sub
Many thanks, this site is great!
__________________edit, the macro now works _________________________
As you can see, I am no VBA expert, but the macro finally works. The code is not neat at all, I am no SW programmer.
Here it is, it might help some one some day.
Sub ProcessFiles_All()
Dim Filename, Pathname, NewPath, FileSource, FileDestination As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.csv")
Do While Filename <> ""
NewPath = Pathname & Left(Filename, 34) & "\"
On Error Resume Next
MkDir (NewPath)
On Error GoTo 0
Set wb = Workbooks.Open(Pathname & Filename)
DoWorkPlease wb ' <------------ It is important to say please!!
On Error Resume Next
wb.Close SaveChanges:=False
if Err.Number <> 0 then
‘Error handler needed here
End if
Filename = Dir()
Loop
End Sub
Sub DoWorkPlease(wb As Workbook)
With wb
‘ Since my application has over 1800 cells for each column and it is time consuming
‘ I use a “testing mode” were I only play with 18 values.
Dim TestingMode As Integer
Dim ThisRange(1 To 4) As Variant
TestingMode = 0
If TestingMode = 1 Then
ThisRange(1) = "B2:CG18"
ThisRange(2) = "CT2:CT18"
ThisRange(3) = "CH2:CN18"
ThisRange(4) = "CN2:CS18"
Rows("19:18201").Select
Selection.Delete Shift:=xlUp
End If
If TestingMode = 0 Then
ThisRange(1) = "B2:CG18201"
ThisRange(2) = "CT2:CT18201"
ThisRange(3) = "CH2:CN18201"
ThisRange(4) = "CN2:CS18201"
End If
‘ speed up the macro, turn off updating and alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
‘ Here is my code that manipulates the cell values from digits (values read by sensors need to be “translated” into real world values. Code not here actually.
‘Then I copy the whole thing into just numbers, there are no longer formulas, easier to work this way.
'_____________________________________
'Get just values - no more formulas
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Sheet1").Select
Columns("A:CT").Select
Selection.Copy
Sheets("Sheet2").Select
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "0"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
‘ Then I save this new workbook into a folder with its own name (and under the folder \FILES\
'_____________________________________
'Save the work under its own folder
Dim CleanName, CleanPath, CleanNewName As Variant
CleanPath = ActiveWorkbook.Path
CleanName = ActiveWorkbook.Name
CleanName = Left(CleanName, 34) ‘I take out the extension
CleanPath = CleanPath + "\" + CleanName
CleanNewName = CleanPath + "\" + CleanName
CleanNewName = CleanNewName + "_clean.csv" ‘ and I add “clean” to have a different name now.
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=CleanNewName, FileFormat:=xlCSV, CreateBackup:=False
‘If there is an error I create an empty folder with the name of the file to know which file needs rework.
If Err.Number <> 0 Then
MkDir (CleanPath + "_error_" + CleanName)
End If
'Resume Next
ActiveSheet.Move _
After:=ActiveWorkbook.Sheets(1)
‘ Then I split the workbook into individual files with the data I need for individual sensors.
‘ Here are the individual ranges I need for each file. Since I have over 1000 files, it is worth the effort.
'_______________ the Split!!______________________________
Dim Col(1 To 98) As Variant
Col(1) = "A:A,B:B,CH:CH,CN:CN,CT:CT"
Col(2) = "A:A,C:C,CH:CH,CN:CN,CT:CT"
Col(3) = "A:A,D:D,CH:CH,CN:CN,CT:CT"
Col(4) = "A:A,E:E,CH:CH,CN:CN,CT:CT"
Col(5) = "A:A,F:F,CH:CH,CN:CN,CT:CT"
Col(6) = "A:A,G:G,CH:CH,CN:CN,CT:CT"
Col(7) = "A:A,H:H,CH:CH,CN:CN,CT:CT"
Col(8) = "A:A,I:I,CH:CH,CN:CN,CT:CT"
Col(9) = "A:A,J:J,CH:CH,CN:CN,CT:CT"
Col(10) = "A:A,K:K,CH:CH,CN:CN,CT:CT"
Col(11) = "A:A,L:L,CH:CH,CN:CN,CT:CT"
Col(12) = "A:A,M:M,CH:CH,CN:CN,CT:CT"
Col(13) = "A:A,N:N,CH:CH,CN:CN,CT:CT"
Col(14) = "A:A,O:O,CH:CH,CN:CN,CT:CT"
Col(15) = "A:A,P:P,CI:CI,CO:CO,CT:CT"
Col(16) = "A:A,Q:Q,CI:CI,CO:CO,CT:CT"
Col(17) = "A:A,R:R,CI:CI,CO:CO,CT:CT"
Col(18) = "A:A,S:S,CI:CI,CO:CO,CT:CT"
Col(19) = "A:A,T:T,CI:CI,CO:CO,CT:CT"
Col(20) = "A:A,U:U,CI:CI,CO:CO,CT:CT"
Col(21) = "A:A,V:V,CI:CI,CO:CO,CT:CT"
Col(22) = "A:A,W:W,CI:CI,CO:CO,CT:CT"
Col(23) = "A:A,X:X,CI:CI,CO:CO,CT:CT"
Col(24) = "A:A,Y:Y,CI:CI,CO:CO,CT:CT"
Col(25) = "A:A,Z:Z,CI:CI,CO:CO,CT:CT"
Col(26) = "A:A,AA:AA,CI:CI,CO:CO,CT:CT"
Col(27) = "A:A,AB:AB,CI:CI,CO:CO,CT:CT"
Col(28) = "A:A,AC:AC,CI:CI,CO:CO,CT:CT"
Col(29) = "A:A,AD:AD,CJ:CJ,CP:CP,CT:CT"
Col(30) = "A:A,AE:AE,CJ:CJ,CP:CP,CT:CT"
Col(31) = "A:A,AF:AF,CJ:CJ,CP:CP,CT:CT"
Col(32) = "A:A,AG:AG,CJ:CJ,CP:CP,CT:CT"
Col(33) = "A:A,AH:AH,CJ:CJ,CP:CP,CT:CT"
Col(34) = "A:A,AI:AI,CJ:CJ,CP:CP,CT:CT"
Col(35) = "A:A,AJ:AJ,CJ:CJ,CP:CP,CT:CT"
Col(36) = "A:A,AK:AK,CJ:CJ,CP:CP,CT:CT"
Col(37) = "A:A,AL:AL,CJ:CJ,CP:CP,CT:CT"
Col(38) = "A:A,AM:AM,CJ:CJ,CP:CP,CT:CT"
Col(39) = "A:A,AN:AN,CJ:CJ,CP:CP,CT:CT"
Col(40) = "A:A,AO:AO,CJ:CJ,CP:CP,CT:CT"
Col(41) = "A:A,AP:AP,CJ:CJ,CP:CP,CT:CT"
Col(42) = "A:A,AQ:AQ,CJ:CJ,CP:CP,CT:CT"
Col(43) = "A:A,AR:AR,CK:CK,CQ:CQ,CT:CT"
Col(44) = "A:A,AS:AS,CK:CK,CQ:CQ,CT:CT"
Col(45) = "A:A,AT:AT,CK:CK,CQ:CQ,CT:CT"
Col(46) = "A:A,AU:AU,CK:CK,CQ:CQ,CT:CT"
Col(47) = "A:A,AV:AV,CK:CK,CQ:CQ,CT:CT"
Col(48) = "A:A,AW:AW,CK:CK,CQ:CQ,CT:CT"
Col(49) = "A:A,AX:AX,CK:CK,CQ:CQ,CT:CT"
Col(50) = "A:A,AY:AY,CK:CK,CQ:CQ,CT:CT"
Col(51) = "A:A,AZ:AZ,CK:CK,CQ:CQ,CT:CT"
Col(52) = "A:A,BA:BA,CK:CK,CQ:CQ,CT:CT"
Col(53) = "A:A,BB:BB,CK:CK,CQ:CQ,CT:CT"
Col(54) = "A:A,BC:BC,CK:CK,CQ:CQ,CT:CT"
Col(55) = "A:A,BD:BD,CK:CK,CQ:CQ,CT:CT"
Col(56) = "A:A,BE:BE,CK:CK,CQ:CQ,CT:CT"
Col(57) = "A:A,BF:BF,CL:CL,CR:CR,CT:CT"
Col(58) = "A:A,BG:BG,CL:CL,CR:CR,CT:CT"
Col(59) = "A:A,BH:BH,CL:CL,CR:CR,CT:CT"
Col(60) = "A:A,BI:BI,CL:CL,CR:CR,CT:CT"
Col(61) = "A:A,BJ:BJ,CL:CL,CR:CR,CT:CT"
Col(62) = "A:A,BK:BK,CL:CL,CR:CR,CT:CT"
Col(63) = "A:A,BL:BL,CL:CL,CR:CR,CT:CT"
Col(64) = "A:A,BM:BM,CL:CL,CR:CR,CT:CT"
Col(65) = "A:A,BN:BN,CL:CL,CR:CR,CT:CT"
Col(66) = "A:A,BO:BO,CL:CL,CR:CR,CT:CT"
Col(67) = "A:A,BP:BP,CL:CL,CR:CR,CT:CT"
Col(68) = "A:A,BQ:BQ,CL:CL,CR:CR,CT:CT"
Col(69) = "A:A,BR:BR,CL:CL,CR:CR,CT:CT"
Col(70) = "A:A,BS:BS,CL:CL,CR:CR,CT:CT"
Col(71) = "A:A,BT:BT,CM:CM,CS:CS,CT:CT"
Col(72) = "A:A,BU:BU,CM:CM,CS:CS,CT:CT"
Col(73) = "A:A,BV:BV,CM:CM,CS:CS,CT:CT"
Col(74) = "A:A,BW:BW,CM:CM,CS:CS,CT:CT"
Col(75) = "A:A,BX:BX,CM:CM,CS:CS,CT:CT"
Col(76) = "A:A,BY:BY,CM:CM,CS:CS,CT:CT"
Col(77) = "A:A,BZ:BZ,CM:CM,CS:CS,CT:CT"
Col(78) = "A:A,CA:CA,CM:CM,CS:CS,CT:CT"
Col(79) = "A:A,CB:CB,CM:CM,CS:CS,CT:CT"
Col(80) = "A:A,CC:CC,CM:CM,CS:CS,CT:CT"
Col(81) = "A:A,CD:CD,CM:CM,CS:CS,CT:CT"
Col(82) = "A:A,CE:CE,CM:CM,CS:CS,CT:CT"
Col(83) = "A:A,CF:CF,CM:CM,CS:CS,CT:CT"
Col(84) = "A:A,CG:CG,CM:CM,CS:CS,CT:CT"
‘ I want to split 84 new files, so for testing I use only 1, and for the real thing I go with 84
Dim CounterMode As Integer
If TestingMode = 1 Then CounterMode = 1 Else CounterMode = 84
For i = 1 To CounterMode
‘ this code takes the columns need, and paste it into a new workbook.
Sheets("Sheet1").Select
Cells.Select
Selection.ClearContents
Range("A1").Activate
Sheets(2).Select
Range(Col(i)).Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:E").EntireColumn.AutoFit
‘ Save the individual file
'_____________save the work________________
Dim ThePath, TheName, TheSwitch As String
ThePath = ActiveWorkbook.Path + “\”
TheName = Left(ActiveWorkbook.Name, 34) ‘ take out the extension from the name
ThePath = ThePath + TheName
TheSwitch = Cells(3, 2) ‘ In Cell (3,2) I have the name of the individual name, so I added to the file name.
TheName = ThePath + "_" + TheSwitch + ".xls"
Range("A1").Select
Sheets("Sheet1").Select
Sheets("Sheet1").Copy
Dim SheetName As Variant
‘ I name Sheets(1) as Sheet1, since the original sheet has the name and date of the test.
‘ I do this to have the same name on all file in order to do a plot, then I rename the sheet with the
‘ original name
SheetName = ActiveSheet.Name
ActiveWorkbook.Sheets(1).Name = "Sheet1"
‘ here is the plot
Columns("A:E").EntireColumn.AutoFit
Columns("B:E").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$B:$E")
ActiveChart.ChartType = xlXYScatterLinesNoMarkers
ActiveWorkbook.Sheets(1).Name = SheetName
‘save
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=TheName, FileFormat:=56, CreateBackup:=False
If Err.Number <> 0 Then
MkDir (ThePath + "_error_" + TheName)
End If
ActiveWorkbook.Close
Next i
'____________________That was the Split__________________________________
' Turn on screenupdating:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("A1").Select
End With
End Sub
Autofilter loop using array
I am having trouble debugging my code. I have an array with the criterial of an autofilter column. My code is supposed to loop through the array, open a set of files and copy-paste information into my workbook.
When I run the code it does not autofiler to the desired criterial and shows a Run-time error 1004. I already tried searching for solutions or similar problems, but found nothing. I also tried recording a macro to change the approach, but when trying to implement the loop it does not work :(
Any help is appreaciated!
Sub Update_Database()
Dim directory As String
Dim fileName As String
Dim my_array() As String
Dim iLoop As Integer
ReDim my_array(18)
my_array(0) = "Aneng"
my_array(1) = "Bayswater"
my_array(2) = "Bad Blankenburg"
my_array(3) = "Halstead"
my_array(4) = "Jorf Lasfar"
my_array(5) = "Kolkatta"
my_array(6) = "Marysville"
my_array(7) = "Northeim"
my_array(8) = "Ponta Grossa"
my_array(9) = "Puchov"
my_array(10) = "Renca"
my_array(11) = "Padre Hurtado"
my_array(12) = "Shanxi"
my_array(13) = "San Luis Potosi"
my_array(14) = "Szeged"
my_array(15) = "Tampere"
my_array(16) = "Uitenhage"
my_array(17) = "Veliki Crljeni"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
directory = .SelectedItems(1)
Err.Clear
End With
fileName = Dir(directory & "\", vbReadOnly)
Dim mwb As Workbook
Set mwb = Workbooks("OEE_Database_Final.xlsm")
Do While fileName <> ""
For iLoop = LBound(my_array) To UBound(my_array)
On erro GoTo ProcExit
With Workbooks.Open(fileName:=directory & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
Selection.AutoFilter Field:=1, Criterial:=my_array(iLoop)
mwb.Worksheets(8).Range("O9:Z2945") = .Worksheets(8).Range("O9:Z2945").Value2
.Close SaveChanges:=False
End With
fileName = Dir
Next iLoop
Loop
ActiveSheet.ShowAllData
ProcExit:
Exit Sub
End Sub
Excel VBA - Loop through folder and add certain parts of names to cells in workbook
I'm trying to perform a simple exercise - (1) merge several tabs (each from separate file) into single file ("macro-file"), (2) rename all tabs in accordance with certain cells in these tabs.
Each tab is effectively a bank statement (in different currencies), so all tabs are of the same structure. I've found a macro (I'm not a specialist in VBA, so this is more about "find and adapt" than "write by myself") to merge them all, so there is no problem with step 1.
However, when I'm trying to rename all tabs at once, I'm getting a conflict - there are three tabs relating to Escrow Account and four tabs relating to Ordinary Account, and there is an intersection in currencies between accounts (each account has USD and EUR, for example).
Currently I have the following code to rename the tabs:
Sub RenameSheet ()
Dim rs As Worksheet
For Each rs In Sheets
If rs.Index > 2 Then
rs.Name = rs.Range("D4")
End If
Next rs
End Sub
What I'm looking for is the solution for problem: if file in a given folder (same as the macro-file) contains "ESCROW", then cell value in cell "D4" in the tab merged to macro-file should be changed from "USD" (let it be a USD bank statement) to "Escrow USD".
The macro should be able to check all files in folder (this is Loop, as far as I understand) and rename respectful cells at once.
Here is the example of code I tried to write-down (unsucessfully though):
Sub RenameSheet ()
Dim fName As String, wb As Workbook, rs As Worksheet
For Each rs In Sheets
If rs.Index > 2 Then
Const myPath As String = "C:\Users\my folder"
If Right(myPath, 1) <> "\" Then fPath = myPath & "\"
fName = Dir(fPath & "*Full*.xlsx*")
v = "ESCROW"
Do Until fName <> ""
If InStr(1, fName, v) > 0 Then
rs.Name = "ESCROW" + rs.Range("D4")
Else
rs.Name = rs.Range("D4")
End If
Loop
End If
Next rs
End Sub
If any of you could help me somehow, I will be grateful.
Any questions are welcome (I understand my language can be a bit tricky).
UPDATE. Current code for tabs merging is below (again, that's not mine, only googled it and inserted to my file, works perfectly):
Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(FileName:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copyafter:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub
There are a few things here and there that I changed before getting to the point:
Reordered and renamed some variables for (hopefully) simplicity
Changed the filter on documents to just *.xl* and added a secondary file filter later with Instr(file, ".xl")
Utilized the With statement for changing the Application settings
But, the important new bit comes in during the loop on each sheet in the source workbook. It does the checks that you used in the initial code - checking if index > 2 and whether "ESCROW" is in the filename - then changes the name accordingly via a With statement.
Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim wbkDestBook, wbkCurSrcBook As Workbook
Dim countFiles, countSheets As Long
Dim wksCurSheet As Worksheet
fnameList = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks (*.xl*),*.xl*", _
Title:="Choose Excel files to merge", _
MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wbkDestBook = ActiveWorkbook
For Each fnameCurFile In fnameList
If InStr(LCase$(fnameCurFile), ".xl") > 0 Then 'second file filter 'prevents e.g. shortcuts (.html files) that can get this far
Set wbkCurSrcBook = Workbooks.Open(filename:=fnameCurFile)
For Each wksCurSheet In wbkCurSrcBook.Sheets
wksCurSheet.copy after:=wbkDestBook.Sheets(wbkDestBook.Sheets.count)
'renaming here
If wbkDestBook.Sheets.count > 2 Then
With wbkDestBook.Sheets(wbkDestBook.Sheets.count)
If InStr(UCase$(fnameCurFile), "ESCROW") Then
.Name = "ESCROW " & .Range("D4").Value2
Else
.Name = .Range("D4").Value2
End If
End With
End If
'end of renaming
countSheets = countSheets + 1
Next
wbkCurSrcBook.Close SaveChanges:=False
countFiles = countFiles + 1
End If
Next
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Procesed " & countFiles & " files." & vbCrLf & "Merged " & countSheets & " worksheets.", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub
Unable to Sort XLS data using Range.Sort
I have a xl file with about 2000 rows and columns from A to H. I was trying to sort the file based on the column D such that all other columns are also sorted accordingly (expand selection area).
I am very new to Macros and have been doing this small task to save some time on my reporting.
Here's what I tried:
Prompt the user to select a file
Set the columns from A to H
Sort Range as D2
Save the file
As I said, I am new, I have used much of the code from sample examples in the MSDN library. Apart from Sort(), every thing else is working for me.
here's the code
Sub Select_File_Windows()
Dim SaveDriveDir As String
Dim MyPath As String
Dim Fname As Variant
Dim N As Long
Dim FnameInLoop As String
Dim mybook As Workbook
Dim SHEETNAME As String
'Default Sheet Name
SHEETNAME = "Sheet1"
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="XLS Files (*.xls),*.xls,XLSX Files (*.xlsx),*.xlsx", _
Title:="Select a file", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = True
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
DoEvents
If Not mybook Is Nothing Then
Debug.Print "You opened this file : " & Fname(N) & vbNewLine
With mybook.Sheets(SHEETNAME)
'Columns("A:H").Sort Key1:=Range("D2:D2000"), Order1:=xlAscending, Header:=xlYes
'Range("A1:H2000").Sort Key1:=Range("D1"), Order1:=xlAscending
Columns("A:H").Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
End With
Debug.Print "Sorter Called"
mybook.Close SaveChanges:=True
End If
Else
Debug.Print "We skipped this file : " & Fname(N) & " because it is already open. Please close the data file and try again"
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Nothing is working for me. The file stays as is and No update is made to it. I could not understand, what is the newbie mistake I have been making here ?
Please help.
References:
https://msdn.microsoft.com/en-us/library/office/ff840646(v=office.15).aspx
http://analysistabs.com/vba/sort-data-ascending-order-excel-example-macro-code/
Run time error 1004 when trying to sort data on three different values
It may be as simple as adding a couple of dots (see pentultimate line below)
With mybook.Sheets(SHEETNAME)
'Columns("A:H").Sort Key1:=Range("D2:D2000"), Order1:=xlAscending, Header:=xlYes
'Range("A1:H2000").Sort Key1:=Range("D1"), Order1:=xlAscending
.Columns("A:H").Sort Key1:=.Range("D1"), Order1:=xlAscending, Header:=xlYes
End With
SJR is correct in saying that your references should be fully qualified inside of the With Statement.
You should simplify your subroutines by extracting large blocks of code into separate subroutines. The fewer tasks that a subroutines handles, the easier it is to read and to debug.
Refactored Code
Sub Select_File_Windows()
Const SHEETNAME As String = "Sheet1"
Dim arExcelFiles
Dim x As Long
arExcelFiles = getExcelFileArray
If UBound(arExcelFiles) = -1 Then
Debug.Print "No Files Selected"
Else
ToggleEvents False
For x = LBound(arExcelFiles) To UBound(arExcelFiles)
If IsWorkbookOpen(arExcelFiles(x)) Then
Debug.Print "File Skipped: "; arExcelFiles(x)
Else
Debug.Print "File Sorted: "; arExcelFiles(x)
With Workbooks.Open(arExcelFiles(x))
With .Sheets(SHEETNAME)
.Columns("A:H").Sort Key1:=.Range("D1"), Order1:=xlAscending, Header:=xlYes
End With
.Close SaveChanges:=True
End With
End If
Next
ToggleEvents True
End If
End Sub
Function IsWorkbookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
IsWorkbookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Function getExcelFileArray()
Dim result
result = Application.GetOpenFilename( _
FileFilter:="Excel Workbooks, *.xls; *.xlsx", _
Title:="Select a file", _
MultiSelect:=True)
If IsArray(result) Then
getExcelFileArray = result
Else
getExcelFileArray = Array()
End If
End Function
Sub ToggleEvents(EnableEvents As Boolean)
With Application
.ScreenUpdating = EnableEvents
.Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual)
.EnableEvents = EnableEvents
End With
End Sub
Read closed .xlsm files as xml files to pull data
I am a new programmer and I am trying to find a way to extract one range of data from multiple workbooks and copy them into a master file. I have already wrote the code to do this below, but the problem that I am having is that my code physically opens the xlsm files > copies the data > then goes back into the master file to paste. Since this is being done to thousands of files at once, it takes hours to complete. My boss told me there is a way to copy the data from the xlsm files without having the code actually open the file if it is read as xml or as a .txt file. I have searched online for this, but cannot find anything on how this would be done. Any help would be greatly appreciated.
The code I have that physically opens the workbooks:
Option Explicit
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim FileType As String
Dim FilePath As String
FileType = "*.xlsm*" 'The file type to search for
FilePath = "C:\Users\hasib\xlsm's\" 'The folder to search
Dim src As Workbook
Dim OutputCol As Variant
Dim Curr_File As Variant
OutputCol = 9 'The first row of the active sheet to start writing to
Curr_File = Dir(FilePath & FileType)
Do Until Curr_File = ""
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open(FilePath & Curr_File, True, True)
Sheets("Reporting").Range("I7:I750").Copy
Workbooks("Master.xlsm").Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Cells(4, OutputCol).Select
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
OutputCol = OutputCol + 1
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Curr_File = Dir
Loop
Set src = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I found out that there is a formula you can use in a cell that will pull in data from a closed workbook. If you type ='folderpath[filename]Sheetname'Cell into a cell it will automatically pull in that information. Using this logic I created the below to loop through all my files and paste data into my workbook from the files being called:
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "c:\"
fd.InitialView = msoFileDialogViewList
fd.AllowMultiSelect = True
FileChosen = fd.Show
FilePath = fd.SelectedItems(1)
FolderPath = Left(FilePath, InStrRev(FilePath, "\"))
If FileChosen = -1 Then
'open each of the files chosen
For c = 1 To fd.SelectedItems.count
FileName = Dir(fd.SelectedItems(c))
ThisWorkbook.Sheets("Batch Results").Cells(OutputRow, OutputCol).Formula = "='" & FolderPath & "[" & FileName & "]Reporting'!$I7"
OutputCol = OutputCol + 1
Next c
End If
ThisWorkbook.Sheets("Batch Results").Select
Cells(1, OutputCol).Select
EndColumn = Split(ActiveCell(1).Address(1, 0), "$")(0)
RangeName = ("A1:" & EndColumn & "1")
Range(RangeName).Select
Selection.AutoFill Destination:=Range("A1:" & EndColumn & "558"), Type:=xlFillDefualt