Wait for big files to open in Excel - vba
I've been trying to loop over a bunch of big .csv files in VBA. Each of them is approximately 50MB. At every iteration I open a new CSV to manipulate data but when the .csv is opening there is a downloading message saying that the file is opening and the progress bar always gets stuck at some point while the VBA is waiting for it to finish.
Actually the .csv is opened because if I click "cancel" on the progress bar the code continues running well but I have to do a manual action at every iteration.
My guess is that VBA goes to the next step while the file is not opened or something like that so maybe if I do a Sleep or something like that it could work but what I tried did not work for now. (I already tried Application.EnableEvents = False). Here is my code:
Sub GetOptions()
Application.DisplayAlerts = False
Application.EnableEvents = False
Set Dates = Sheets("Dates")
Set Res = Sheets("Options")
Dim dateToday As Date
ETF = "SPY"
nrows = Dates.Cells(Rows.Count, 1).End(xlUp).Row
For i = 708 To nrows
If Dates.Cells(i, 2).Value = "B" Then
dateToday = Dates.Cells(i, 1).Value
dateYear = Year(dateToday)
stringOpening = "P:\Options Database\CSV\" & dateYear & "\bb_" & dateYear & "_" & GetMonth(dateToday) & "\bb_options_" & Format(dateToday, "yyyymmdd") & ".csv"
Workbooks.Open stringOpening, UpdateLinks:=0, ReadOnly:=True
Set Options = Workbooks("bb_options_" & Format(dateToday, "yyyymmdd")).Sheets(1)
Do things...
Workbooks("bb_options_" & Format(dateToday, "yyyymmdd")).Close SaveChanges:=False
End If
Next i
End Sub
A trick would be :
to open them as Read/Write files,
wait for the Write status which indicates that it is fully opened
set back the file to Read Only
This code loops until the file goes into a Write status :
Sub myWaitForFileOpen()
Dim wb As Workbook
Set wb = Application.Workbooks.Open("C:\File.xls")
Do Until wb.ReadOnly = False
wb.Close
Application.Wait Now + TimeValue("00:00:01")
Set wb = Application.Workbooks.Open("C:\File.xls")
Loop
'Then the code that needs that Workbook open here!
'Or Call That other macro here!
End Sub
Here is your full code, that will open the CSV in Read/Write until it is fully loaded and then put it back to read only :
Sub GetOptions()
Dim wB As Workbook
Application.DisplayAlerts = False
Application.EnableEvents = False
Set Dates = Sheets("Dates")
Set Res = Sheets("Options")
Dim dateToday As Date
ETF = "SPY"
nrows = Dates.Cells(Rows.Count, 1).End(xlUp).Row
For i = 708 To nrows
If Dates.Cells(i, 2).Value = "B" Then
dateToday = Dates.Cells(i, 1).Value
dateYear = Year(dateToday)
stringOpening = "P:\Options Database\CSV\" & dateYear & "\bb_" & dateYear & "_" & GetMonth(dateToday) & "\bb_options_" & Format(dateToday, "yyyymmdd") & ".csv"
Set wB = Workbooks.Open(stringOpening, UpdateLinks:=0, ReadOnly:=False)
Do Until wB.ReadOnly = False
wB.Close
Application.Wait Now + TimeValue("00:00:01")
Set wB = Application.Workbooks.Open("C:\My Files\AAA.xls")
Loop
wB.ReadOnly = True
Set Options = wB.Sheets(1)
Do
'things...
Loop
wB.Close SaveChanges:=False
End If
Next i
End Sub
If you want to open the file and use it immediately Excel might
give an error because Excel activates file opening process and goes to execute next statement. A quick and dirty workaround for not very long files is to introduce an extra code that is not related to a file thus keeping Excel busy while file is going through the opening process.
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
Code does not contiue after file is opened via dialogue
I'm quite confused right now... I have two modules open_files and start_comparison. From start_comparison I'm calling open_files, which is supposed to open the file open dialogue. The user is then supposed to select one file and hit open. Via start_comparison the user is supposed to open two files. However sometimes (this is where I'm confused) the code opens the first file, but then simply exit's start_comparison occasionally. Sometimes it works, sometimes not, and I have no clue when and why. Below is the code. What I thought is: When the file dialogue is displayed, one can double click the file and the file will be openend, which would trigger a hidden exit. However, I couldn't confirm this hypthesis. When I step through, everything works fine. What is your idea about the problem? Sub start_comparison() Dim cell As Range Dim control_file_storage_bins As Range Dim last_row_CONTROLFILE As Long Application.ScreenUpdating = False Set ws_control_file = ActiveWorkbook.ActiveSheet Range("A2:Z1048576").Clear Call open_files("PHYSICAL STOCK", 1) Call open_files("STORAGE BINS", 2) 'Copy stock information With ws_control_file .Range("A2:A" & last_row_PHYSICALSTOCK).Value = ws_physical_stock.Range("B2:B" & last_row_PHYSICALSTOCK).Value .Range("B2:B" & last_row_PHYSICALSTOCK).Value = ws_physical_stock.Range("C2:C" & last_row_PHYSICALSTOCK).Value .Range("C2:C" & last_row_PHYSICALSTOCK).Value = ws_physical_stock.Range("J2:J" & last_row_PHYSICALSTOCK).Value .Range("D2:D" & last_row_PHYSICALSTOCK).Value = ws_physical_stock.Range("K2:K" & last_row_PHYSICALSTOCK).Value .Range("E2:E" & last_row_PHYSICALSTOCK).Value = ws_physical_stock.Range("E2:E" & last_row_PHYSICALSTOCK).Value End With Set control_file_storage_bins = ws_control_file.Range("A2:A" & last_row_PHYSICALSTOCK) For Each cell In rng_STORAGEBIN If (WorksheetFunction.CountIf(control_file_storage_bins, cell.Value) = 0) Then 'Storage Bin empty With ws_control_file last_row_CONTROLFILE = .Cells(Rows.Count, "A").End(xlUp).Row + 1 .Cells(last_row_CONTROLFILE, "A").Value = cell.Value .Range("B" & last_row_CONTROLFILE & ":E" & last_row_CONTROLFILE).Value = "BIN EMPTY" End With End If Next cell wb_physical_stock.Close (False) wb_storage_bins.Close (False) Application.ScreenUpdating = True MsgBox "Success!" End Sub Other procedure: Sub open_files(file_type As String, wb_object As Integer) Dim last_row_STORAGEBIN As Long MsgBox "Please select the relevant " & file_type & " extract!" With Application.FileDialog(msoFileDialogOpen) .AllowMultiSelect = False .Show Workbooks.Open (.SelectedItems(1)) Select Case wb_object Case 1 'Physical Stock Set wb_physical_stock = ActiveWorkbook With wb_physical_stock Set ws_physical_stock = ActiveSheet last_row_PHYSICALSTOCK = ws_physical_stock.Cells(Rows.Count, "A").End(xlUp).Row End With Case 2 'Storage Bins Set wb_storage_bins = ActiveWorkbook With wb_storage_bins Set ws_storage_bins = ActiveSheet last_row_STORAGEBIN = ws_storage_bins.Cells(Rows.Count, "A").End(xlUp).Row - 1 Set rng_STORAGEBIN = ws_storage_bins.Range("A2:A" & last_row_STORAGEBIN) End With End Select End With End Sub In case, here is the private variable declaration: Private wb_physical_stock As Workbook, wb_storage_bins As Workbook Private ws_physical_stock As Worksheet, ws_storage_bins As Worksheet, ws_control_file As Worksheet Private last_row_PHYSICALSTOCK As Long Private rng_STORAGEBIN As Range EDIT: I was now checking the procedure open_files with breakpoints. If I set a breakpoint BEFORE Workbooks.Open and run from there again with F5 everything is fine. However, if I set a breakpoint AFTER Workbooks.Open, the breakpoint isn't even triggered. Any ideas? EDIT2: Previously the macro was started via a short-cut. Now I changed that to an ActiveX-Control and it works fine. Same tested with simple forms and buttons (form control).
If you suspect that opening a file triggers some code, disable events before opening it - this will prevent to execute any (autoexec-) macros withing that file. Another topic that you should address is that the user might press the "Cancel"-button, else you will run into a runtime error. You can check this with the result of the show-method, it will return False if the dialog was cancelled With Application.FileDialog(msoFileDialogOpen) .AllowMultiSelect = False if .Show then application.EnableEvents = False Workbooks.Open (.SelectedItems(1)) application.EnableEvents = True (...) else ' You have to make up your mind what to do in that case... end if end with
VBA error when saving workbook sheet in new file location during data refresh
I am having issues with my VBA code and am by no means an expert with VBA. This code is tied to product usage data for 30 clients. The current workbook I am using contains multiple tabs but I only want to focus on one tab, the "Template" tab, as my desired output. What I am trying to set up is a macro with an auto save of each individual clients data into its own new workbook in a specific folder location. So basically I only want one tab(ie sheet) saved out of the entire workbook for each client. The list of clients comes from a data validation list that is tied to a table. Within the macro itself is a .RefreshAll since the data needs to be refreshed for each individual client to produce the output needed in the "Template" tab. The underlying data is tied to both Power Query and T-SQL linked to a MS SQL Server. This is what I am seeing: When the file is saved I receive a run time error '1004' so the saving of the new file fails. In addition, the data refresh needs to run and finish for each individual client before moving on the the next. Which I do not believe is occurring. Here is how I want the macro to work: Data refresh begins for first client in data validation drop down list Refresh completes "Template" sheet is copy and saved from workbook into a new workbook New workbook is placed in a new file location File name includes client name, today's date, and .xlsx extension VBA code is removed from file that was copied. Steps 1-6 repeat for the next client until it has gone through entire list of clients. Here is the current code I am working with: Sub ClientDataRefresh() With ActiveWorkbook.Worksheets("Output") Dim r As Long, i As Long r = Range("Clients").Cells.Count For i = 1 To r Range("C5") = Range("Clients").Cells(i) ActiveWorkbook.RefreshAll Worksheets("Output").Range("A1:O10").Columns.AutoFit With ActiveWorkbook.Worksheets("Template") LR = .Cells(Rows.Count, 7).End(xlUp).Row 10: If .Cells(LR, 7) = "" Then LR = LR - 1: GoTo 10 .PageSetup.PrintArea = "$A$1:$I$" & LR End With thisDate = Replace(Date, "\", " - ") thisName = Sheets("Template").Range("H7").Text filePath = "C:\Users\nalanis\Documents\Sales\" Application.DisplayAlerts = False ActiveWorkbook.Worksheets("Template").Select ActiveWorkbook.Worksheets("Template").Copy ActiveWorkbook.Worksheets("Template").SaveAs Filename:=filePath & thisName & thisDate & ".xlsx", FileFormat:=xlOpenXMLWorkbook Application.DisplayAlerts = True Next i End With End Sub Any feedback is most appreciative. Thank you NEW CODE Sub ClientDataRefresh() With ActiveWorkbook.Worksheets("Output") Dim r As Long, i As Long r = Range("Clients").Cells.Count For i = 1 To r Range("C5") = Range("Clients").Cells(i) ActiveWorkbook.RefreshAll DoEvents Worksheets("Output").Range("A1:O10").Columns.AutoFit thisDate = Replace(Date, "/", "-") thisName = Sheets("Template").Range("H7").Text filePath = "C:\Users\nalanis\Dropbox (Decipher Dev)\Analytics\Sales\" Application.DisplayAlerts = False ActiveWorkbook.Worksheets("Template").Select ActiveWorkbook.Worksheets("Template").Copy ActiveWorkbook.Worksheets("Template").SaveAs Filename:=filePath & thisName & " " & "Usage Report" & " " & thisDate & ".xlsx", FileFormat:=xlOpenXMLWorkbook Application.DisplayAlerts = True Next i End With With ActiveWorkbook.Worksheets("Template") LR = .Cells(Rows.Count, 7).End(xlUp).Row 10: If .Cells(LR, 7) = "" Then LR = LR - 1: GoTo 10 .PageSetup.PrintArea = "$A$1:$I$" & LR End With End Sub .PageSetup.PrintArea = "$A$1:$I$" & LR End With Next c End Sub
Change this: thisDate = Replace(Date, "\", " - ") to this: thisDate = Replace(Date, "/", " - ")
Excel VBA Suddenly Goes To Design Mode during Macro Runtime
Hope someone help me with this problem. I have a subroutine that will copy my data from this workbook to another existing workbook(Report Workbook). When I try to run the code, during run-time once it opens the Report Workbook it suddenly stops and I've notice that it goes to design mode. Thus, hindering the execution of the routine. But when I try to put a break point on the subroutine and continue it again. It executes without problem. This seems a bit odd. I'm a bit out of the corner trying to figure this out. So far this are the troubleshooting steps that I've tried. Tried to run the Workbook in another machine. I have tried deleting all the Workbook_Open on the Report Workbook. Tried to delete all the Macro Codes on the Report Workbook. Insert an error handler. Unfortunately, no error is presented. Tried to delete the DoEvents code on the subroutine. But still no luck. It stops the code from executing. Private Sub TransferRawData() Dim wsPTRawData As Worksheet, wbPTWorkBook As Workbook, wsOutputRaw As Worksheet Dim filePath As String, FileName As String, ptTargetRow As Long Application.EnableEvents = False Application.StatusBar = "Exporting All Raw Data... Please wait a moment..." Application.ScreenUpdating = False Application.Calculation = xlCalculationManual filePath = ThisWorkbook.Path & "\" FileName = filePath & pt_FileName Set wbPTWorkBook = Workbooks.Open(FileName:=FileName, UpdateLinks:=0, IgnoreReadOnlyRecommended:=True) DoEvents Set wsPTRawData = wbPTWorkBook.Worksheets(pt_ProdRawSheet) Set wsOutputRaw = ThisWorkbook.Sheets(merger_prodOutputSheet) ptTargetRow = wsPTRawData.Range("A" & Rows.Count).End(xlUp).Row + 1 If lastRow(wsOutputRaw, "A") > 1 Then wsOutputRaw.Range("A2:F" & lastRow(wsOutputRaw, "A")).Copy wsPTRawData.Range("A" & ptTargetRow) wbPTWorkBook.Close True Set wsOutputRaw = Nothing Set wsPTRawData = Nothing Set wbPTWorkBook = Nothing End Sub BTW, I have 3 set of workbook that uses the above code. All of them will copy the data on the Report Workbook. But all of them are having trouble in executing the transfer routine. For additional Information. Once I run the routine and it executes the Workbooks.Open Event. Here is the screenshot of the VBA Project Window and Excel Window.
Add an error handler in here and see if there are any errors that aren't being caught properly Private Sub TransferRawData() Dim wsPTRawData As Worksheet, wbPTWorkBook As Workbook, wsOutputRaw As Worksheet Dim filePath As String, FileName As String, ptTargetRow As Long Application.EnableEvents = False Application.StatusBar = "Exporting All Raw Data... Please wait a moment..." Application.ScreenUpdating = False Application.Calculation = xlCalculationManual filePath = ThisWorkbook.Path & "\" FileName = filePath & pt_FileName On Error GoTo ErrHandler Set wbPTWorkBook = Workbooks.Open(FileName:=FileName, UpdateLinks:=0, IgnoreReadOnlyRecommended:=True) DoEvents Set wsPTRawData = wbPTWorkBook.Worksheets(pt_ProdRawSheet) Set wsOutputRaw = ThisWorkbook.Sheets(merger_prodOutputSheet) ptTargetRow = wsPTRawData.Range("A" & Rows.Count).End(xlUp).Row + 1 If lastRow(wsOutputRaw, "A") > 1 Then wsOutputRaw.Range("A2:F" & lastRow(wsOutputRaw, "A")).Copy wsPTRawData.Range("A" & ptTargetRow) wbPTWorkBook.Close True Set wsOutputRaw = Nothing Set wsPTRawData = Nothing Set wbPTWorkBook = Nothing ErrHandlerSave: Debug.Print Chr(13) & "Error # " & Str(Err.Number) & " was generated on Saving" _ & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description End Sub You'll see an error message come up in the Immediate window at the bottom of the VBA code. If you don't have it up or unsure how to show it LOOK HERE
Hi For Reference of others that will encounter this issue on the future. The code itself doesn't have anything to do with the error. After a lot of time investigating this error. I have found out that the culprit is the shortcut key that I have assigned on the Macro itself. I have assigned a CTRL+SHIFT Key on the macro thus hindering the other macro of the other workbook that its opening. Going forward, I made configuration on my Macro shortcut key and avoided the Shift key. As a result, the subroutine do what it needs to supposed to do.
Making excel macro for file scanning more stable
I was curious if anybody could provide suggestions on how I can make an excel macro more stable. The macro prompts the user for a path to a folder containing files to scan. The macro then iterates for every file in this folder. It opens the excel file, scans Column D for the word fail, then copies that row of data to the data sheet in the excel file where this macro is programmed. For the most part the macro runs perfectly but sometimes I get run time errors or 'excel has stopped working' errors. I can scan through 5000+ files at a time and the macro takes a while to run. Any suggestions would be appreciated. Thanks! Sub findFail() Dim pathInput As String 'path to file Dim path As String 'path to file after being validated Dim fileNames As String 'path to test file Dim book As Workbook 'file being tested Dim sheet As Worksheet 'sheet writting data to Dim sh As Worksheet 'worksheet being tested Dim dataBook As Workbook 'where data is recorded Dim row As Long 'row to start writting data in Dim numTests As Long 'number of files tested Dim j As Long 'counter for number of files tested Dim i As Long 'row currently being tested Dim lastRow As Long 'last row used Dim startTime As Double 'time when program started Dim minsElapsed As Double 'time it took program to end Application.ScreenUpdating = False j = 0 i = 1 row = 2 Set dataBook = ActiveWorkbook Set sheet = Worksheets("Data") sheet.Range("A2:i1000").Clear startTime = Timer '-----Prompt for Path----- pathInput = InputBox(Prompt:="Enter path to files. It must have a \ after folder name.", _ Title:="Single Report", _ Default:="C:\Folder\") If pathInput = "C:\Folder\" Or pathInput = vbNullString Then 'check to make sure path was inputed MsgBox ("Please enter a valid file path and try again.") Exit Sub Else path = pathInput 'path = "C:\Temp\212458481\" ' Path for file location fileNames = Dir(path & "*.xls") 'for xl2007 & "*.xls?" on windows '-----begin testing----- Do While fileNames <> "" 'Loop until filename is blank Set book = Workbooks.Open(path & fileNames) Set sh = book.Worksheets(1) lastRow = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).row If sh.Cells(lastRow, 2).Value - sh.Cells(1, 2).Value >= 0.08333333 Then Do While sh.Range("D" & i).Value <> "" 'loop untile there are no rows left to test If sh.Range("D" & i).Value = "Fail" Then 'record values if test result is false sheet.Range("A" & row).Value = book.Name sheet.Range("B" & row).Value = Format(sh.Range("B" & i).Value - sh.Range("B1").Value, "h:mm:ss") sheet.Range("C" & row).Value = sh.Range("A" & i).Value sheet.Range("D" & row).Value = Format(sh.Range("B" & i).Value, "h:mm:ss") sheet.Range("E" & row).Value = sh.Range("C" & i).Value sheet.Range("F" & row).Value = sh.Range("D" & i).Value sheet.Range("G" & row).Value = sh.Range("E" & i).Value sheet.Range("H" & row).Value = sh.Range("F" & i).Value sheet.Range("I" & row).Value = sh.Range("G" & i).Value row = row + 1 Exit Do End If i = i + 1 Loop j = j + 1 dataBook.Sheets("Summary").Cells(2, 1).Value = j End If book.Close SaveChanges:=False fileNames = Dir() i = 1 Loop numTests = j Worksheets("Summary").Cells(2, "A").Value = numTests minsElapsed = Timer - startTime Worksheets("Summary").Cells(2, "B").Value = Format(minsElapsed / 86400, "hh:mm:ss") End If End Sub
Without the same dataset as you we, can not definitively supply an answer but I can recommend the below which is related to the error you are seeing. Try freeing/destroying the references to book and sh. You have a loop that sets them:- Do While fileNames <> "" 'Loop until filename is blank Set book = Workbooks.Open(path & fileNames) Set sh = book.Worksheets(1) However the end of the loop does not clear them, ideally it should look as below:- Set sh = Nothing Set book = Nothing Loop This is a better way to handle resources and should improve memory usage. As a poor example, without it your code is saying, sh equals this, now it equals this instead, now it equals this instead, now it equals this instead, etc... You end up with the previous reference that was subsequently overwritten being a sort of orphaned object that is holding some space in memory.
Depending on your case, you may use the following to make it faster -by turning off excel processes that you don't really need at the time of your macro execution- Sub ExcelBusy() With Excel.Application .Cursor = xlWait .ScreenUpdating = False .DisplayAlerts = False .StatusBar = False .Calculation = xlCalculationManual .EnableEvents = False End With End Sub In your sub Dim startTime As Double 'time when program started Dim minsElapsed As Double 'time it took program to end Call ExcelBusy ... As a comment, you never set back screenupdating to true in your sub, that may lead to strange behavior in excel, you should turn everything to default after you are done with your stuff. OT: Some processes can't be optimized any further -sometimes-, by what you are saying -scanning over 5k files?- surely it's going to take a time, you need to work in how to communicate the user that is going to take a while instead -perhaps an application status bar message or a user form showing process?-.