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?-.