VBA While Loop Exiting Early [duplicate] - excel

This question already has an answer here:
VB Do While only works for one iteration
(1 answer)
Closed 2 years ago.
I am looping through a folder of .csv files and running another macro on each of them. However despite there being multiple files in the folder the loop always ends after the first iteration. Does anyone know the solution to this?
Here is the first macro which just loops through the files in the folder
Sub looper()
Dim root, workbookname As Long
Dim csvName As Variant
root = ThisWorkbook.Path
csvName = Dir(root & "\CSVs\")
While csvName <> ""
csvName = Left(csvName, Len(csvName) - 4)
Call get_data(root, csvName)
csvName = Dir 'set the csvname to the next csv
Wend
'***THE LOOP BREAKS OUT AFTER THE FIRST ITERATION***
MsgBox ("Finished Looping Through CSVs - Trends Saved in 'Trends' Folder of Same Directory")
ActiveWorkbook.Close
End Sub
This macro scrapes the data from the csv into the open workbook and does various formatting measures.
Sub get_data(path_root, workbookname)
Dim CSV_path, pathname As String
Dim TRD_wb As Workbook: Set TRD_wb = ThisWorkbook
Dim CSV_wb As Workbook
Dim lrow As Long
Application.ScreenUpdating = False
'delete any old data in the template
ActiveSheet.Rows(4 & ":" & ActiveSheet.Rows.Count).Delete
CSV_path = path_root + "\CSVs\" 'get path for csvs folder
'*** CHANGE THIS FOR THE LOOP FOR EACH CSV ***
CSV_name = Dir(CSV_path & workbookname & ".csv")
Workbooks.Open (CSV_path & CSV_name)
Set CSV_wb = ActiveWorkbook
Call sort_delete_format_csv 'format the csv data
'Application.Wait (Now + TimeValue("0:00:10"))
'get data from csv
Range("A5:J5").Select 'select first row of data
Range(Selection, Selection.End(xlDown)).Select 'select all rows to the bottom of sheet
Selection.Copy
TRD_wb.Activate 'select the template sheet
ActiveSheet.Paste Destination:=Worksheets("Trends").Range("A3") 'paste the data in
'copy pasted titles over from the csv
CSV_wb.Activate
Range("e4:j4").Copy
TRD_wb.Activate
ActiveSheet.Paste Destination:=Worksheets("Trends").Range("E1")
CSV_wb.Close savechanges:=False 'close csv without saving so raw data is left uncorrupted in case of error
With ActiveSheet
lrow = Cells(Rows.Count, 1).End(xlUp).Row 'find the number of the last row
End With
Range("k3:n3").Select
Selection.AutoFill Destination:=Range("K3:N" & lrow) 'autofill the in cell functions for graph
'save with name of csv in folder- datestamp folder?
'loop for all csvs
Application.ScreenUpdating = True
pathname = path_root & "\Trends\"
ActiveWorkbook.SaveAs pathname & workbookname, FileFormat:=xlOpenXMLWorkbookMacroEnabled
End Sub

You have another Dir call inside your get_data function.
Dir only has one state for your whole script. You cannot nest loops that use Dir, because the inner call will erase the previous state and set a new one!
What you can do is write all the filenames into an array at once, and then loop over that array.

Related

Iteratively break out a data file to a template file and save as a new file for every 5,000 rows

I am trying to break out a data file by 5,000 rows due to limitation with a tool. I have a template file that has multiple sheets (I only have to update data on the first sheet titled 'Service Template', but I need all tabs present on the newly created files). The tool requires the template file to be used so I have to use that file instead of copying the data to a completely new file. I am also attempting to do this on a Mac, but can use virtual machine if absolutely necessary.
The data file and the template file both start on row 2 as both files have headers.
I have the below code that I have been trying to build out but it is still not working and I am stuck.
Data file sheet = 'Sheet1' and Template File Sheet = 'Service Template'
Sub test()
Dim lastRow As Long, myRow As Long, myBook As Workbook
ActiveSheet.Name = "Sheet1"
lastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For myRow = 1 To lastRow Step 5000
Set myBook = Workbooks.Open("/Users/Downloads/Test/TemplateFile.xlsx")
ThisWorkbook.Sheets("Sheet1").Rows(myRow & ":" & myRow + 4999).EntireRow.Copy myBook.Sheets("Sheet1").Range("A2")
Application.DisplayAlerts = False
myBook.SaveAs Filename:="\Users\Downloads\Test\" & myBook.Name
Application.DisplayAlerts = False
myBook.Close
Next myRow
End Sub
I am looking to transfer 5000 rows (starting row2) from the data file to the template file (starting row2) save as a new file and then keep doing the same process until all of the rows are complete.
Try something like this:
Sub test()
Const BLOCK_SIZE As Long = 5000
Dim wsSrc As Worksheet, myBook As Workbook, rngCopy As Range
Set wsSrc = ActiveSheet 'or some other specific sheet
Set rngCopy = wsSrc.Rows(2).Resize(BLOCK_SIZE)
Do While Application.CountA(rngCopy) > 0 'loop while range has content
With Workbooks.Open("/Users/Downloads/Test/TemplateFile.xlsx")
rngCopy.Copy .Worksheets("Sheet1").Range("A2")
.SaveAs "\Users\Downloads\Test\" & "R" & rngCopy.Row & "_" & .Name
.Close SaveChanges:=True
End With
Set rngCopy = rngCopy.Offset(BLOCK_SIZE) 'next block down
Loop
End Sub

Excel crashing randomly when running macro

I'm having an issue with the following code, that is supposed to sequentially open 〜100 csv files, check for a value in a cell (validation, if it is file with correct structure), copy single line of data and paste it into ThisWorkbook.Worksheets("2 CSV").Range("B" & row_number).
This solution worked for two years until this month. Now the whole Excel crashes randomly on any file without any error message. Sometimes it manages to loop through 20 files, sometimes 5.
The weirdest thing is, that I can loop manually using F8 through the whole thing without any problem.
The macro:
Sub b_load_csv()
Dim appStatus As Variant
Dim folder_path As String 'folder path to where CSVs are stored
Dim file_name As String 'file name of current CSV file
Dim row_number As Integer 'row number in target sheet
Dim source_sheet_name As String 'name of the source sheet of the CSV = CSV file name
Dim wb_src As Workbook 'variable for opened CSV source workbook
Dim sht_src As Worksheet 'variable for opened CSV source sheet
Dim sht_csv As Worksheet 'variable for target sheet in ThisWorkbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
If .StatusBar = False Then appStatus = False Else appStatus = .StatusBar 'show currently processing file in status bar
End With
folder_path = "C:\Folder\SubFolder\" 'here are the files stored
file_name = Dir(folder_path & "*.csv") 'using dir to get file names
row_number = 3 'row number for pasting values
Set sht_csv = ThisWorkbook.Worksheets("2 CSV") 'target sheet for data aggregation
Do While file_name <> ""
Workbooks.Open (folder_path & file_name), UpdateLinks:=False, Local:=True 'open csv file
Set wb_src = Workbooks(file_name) 'assign opened csv file to variable
source_sheet_name = Left(file_name, InStr(file_name, ".") - 1) 'sheet name in csv is the same as the file name
Set sht_src = wb_src.Worksheets(source_sheet_name) 'assign source sheet to variable
If sht_src.Range("C1").Value2 = "OJ_POPIS" Then 'checks if the csv has the correct structure
sht_src.Range("A2:FZ2").Copy 'if so copies desired range
sht_csv.Range("B" & row_number).PasteSpecial 'and pastes it into target worksheet column B
End If
sht_csv.Range("A" & row_number).Value2 = file_name 'writes file name into column A
Application.CutCopyMode = False
wb_src.Close SaveChanges:=False
file_name = Dir() 'fetch next file name
row_number = row_number + 1
'the following lines is what I tried to fix the problem of random excel crashing
Set wb_src = Nothing
Set sht_src = Nothing
Application.StatusBar = "Processing file " & file_name
DoEvents
Application.Wait (Now + TimeValue("0:00:02"))
ThisWorkbook.Save 'save after every loaded file to see which files are causing the problem
Loop
MsgBox "Data from CSV files copied", vbOKOnly
Set sht_csv = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Source CSV files are encoded both in UTF-8 and ANSI (my ACP is ANSI, 1250) and ; delimited.
Group policy restricting macros doesn't apply to me. I can sign my own macros.
What I tried:
Lines of code at the end of the loop
Identifying and deleting files triggering the crash (they have nothing in common, seemingly random, by the time a remove half of them... what is the point)
Simplifying the macro
New workbook
Different machine
VPN On/Off
Thank you for your help!
First thing I'd try is include a proper error handler (not resume next), particularly with x64, and ensure 'Break on all unhandled errors' is selected in Tools / Options / General.
Second thing I'd try is avoid using the clipboard -
With sht_src.Range("A2:FZ2")
sht_cvs.Range("B" & row_number).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
(no need then to clear CutCopyMode)
Third thing I'd try is don't filter with Dir but something like this -
sFilter = "*.cvs"
file_name = Dir$(, 15) ' without vbDirectory if not getting subfolders
Do While Len(file_name)
If file_name Like sFilter Then
' process file
End If
file_name = Dir$(, 15)
Loop
Fourth thing I'd try is a good cup of coffee!

Copy non adjacent data cells into one workbook

this is the code that i am currently using right now, but its not enough to meet my objectives and i am stuck on how to continue....
So this code will copy the specified data from many other excel workbook in the form of xlsx into a main excel workbook and before that it will scan through the folder which contains all the different data files and the main file(all files supposed to be transfered here in a table form) e.g. Test3.xlsx,Test4.xlsx,Test.xlxs and Main.xlsm in the folder of ScanFiles. so everytime a new files comes into the folder, it will automatically update the main workbook by opening the data workbooks then copy the required data and paste it on the main workbook upon clicking a button.
Sub ScanFiles()
Dim myFile As String, path As String
Dim erow As Long, col As Long
path = "c:\Scanfiles\"
myFile = Dir(path & "*.xlsx")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
Set copyrange = Sheets("sheet1").Range("A18,B18,C18,D18,A19,B19,C19,D19")
Windows("master-wbk.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
cel.Copy
Cells(erow, col).PasteSpecial xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Objectives: 1st:orignal type of file is in "file" not xlsx, so hope to find a way to open the file in xlsx format automatically before start of copying data.
2nd: requires 3 types of specified data e.g. name,surname(both of them are in fixed position always in A18 to D18 and A19 to D19 , 3rd one is to find the date, however the date is almost always in different positions in the data sheet, so i hope to add on a part to the code that makes it search for something like "ended 20190808" it will always start with ended but will always be in diff rows or even columns. i also need to arrange the data according to the date from newest(top) to oldest(bottom) and state the month of the date in words instead of numbers e.g. june
Deeply Appreciate any form of help but if possible the small section of code that can add on to my coding will make it a lot easier because im tasked to do this in a very limited amount of time
Thank you!!!
Here's some code that does similar things to what you describe. The animated .gif shows it working by stepping through the code. First the 2 data (.xlsx) files are shown so you have an idea of their content. Each is located in the same folder as the main workbook and has data in column A. Then as we step through the code each file is opened, its data manipulated (row 3 is deleted) and transferred into adjacent columns of the main workbook. The code is not limited to .xlsx files and will work with text files as well, as long as ext is defined.
Hopefully, once you understand how this works you can modify it to apply it to your case.
Option Explicit
Sub CombineFiles()
Dim theDir As String, numFiles As Integer
Dim sh As Worksheet, wk As Workbook, newSheet As Worksheet
Dim newColumn As Range, r As Range, s As String
Const ext = ".xlsx"
Err.Clear
theDir = ThisWorkbook.Path
Set newSheet = ThisWorkbook.Sheets.Add
newSheet.Name = "Combined"
Set newColumn = newSheet.Range("A1")
'Loop through all files in directory
s = Dir(theDir & "\*" & ext)
While s <> ""
numFiles = numFiles + 1
On Error Resume Next
Set wk = Workbooks.Open(theDir & "\" & s)
Set sh = ActiveSheet
sh.Rows(3).Delete Shift:=xlUp
Set r = Range("A1")
Range(r, r.End(xlDown)).Copy
newSheet.Activate
newColumn.Offset(0, numFiles) = wk.Name
newColumn.Offset(1, numFiles).Select
newSheet.Paste
Application.DisplayAlerts = False
wk.Close False
Application.DisplayAlerts = True
s = Dir()
Wend
MsgBox (numFiles & " files were processed.")
End Sub
For copy/paste of pictures see examples on this or this page. To find the last cell containing data in a column see this page; note that one example involves using the .find command. More generally, to learn how to use .find in vba, use the macro recorder and then adjust the resulting code.

How to copy data from only the new excel files that are saved in a predefined folder?

I want to copy specific range from excel files stored in a specific folder and paste it in another excel file.I am able to do so.However,every time i run the code it starts with the very first file in the folder.I want to copy data from only the files that haven't been updated before.Is there a way to do that?
EG:
"file1.xlsx" and "file2.xlsx" are in a folder. I want to copy data from the given files and paste it in "NewFile.xlsm" (I'm able to achieve this) However, if I add "file3.xlsx" and "file4.xlsx" in the folder and then run the macro, it copies data from "file1.xlsx" and "file2.xlsx" as well.I want it to copy data only from "file3.xlsx" and "file4.xlsx" this time as the data from previous 2 files is already saved.
(The code i have is given below)
Path = "C:\Users\National\Desktop\TEST Codes\PO\Excel\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
If Filename = "Z master for PO.xlsm" Then
Exit Sub
End If
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Sheets("DETAILED").Range("A3:S15").Copy
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveWorkbook.Close
Dim LASTROW As Long, WS As Worksheet, LS As Long
Set WS = Sheets("sheet1")
LASTROW = WS.Range("R" & Rows.Count).End(xlUp).Row + 1
WS.Range("A" & LASTROW).Select
ActiveSheet.Paste Destination:=WS.Range("A" & LASTROW)
Application.CutCopyMode = False
Filename = Dir()
Loop
Range("A7").Select
One way of doing this is by looking at the DateLastAccessed property, or the DateLastModified property. These are both properties of the File object, see this MS documentation.
You can set a minimum date/time, which should exclude the files you don't want processed.
Be sure to set the correct reference
Option Explicit
Sub GoThroughFiles()
Dim Path As String, Filename As String,
Dim fso, fileinfo
Set fso = CreateObject("Scripting.FileSystemObject")
Path = "C:\Users\National\Desktop\TEST Codes\PO\Excel\"
Filename = Dir(Path & "*.xls")
Set fileinfo = fso.GetFile(Path & Filename)
Do While Len(Filename) > 0
If fileinfo.DateLastAccessed > DateAdd("n", -5, Now) 'If the file was last accessed less than 5 minutes ago
'Do stuff with the file
End If
FileName = Dir()
Loop
End Sub
Furthermore, avoid using Select and Activate as using both will make your code prone to errors. Here is a thread on how to avoid it. Next to that, I added Option Explicit which makes sure you avoid other errors caused by, for example, spelling mistakes.

VBA looping through files that meet two criteria

Below is working code that is looping through files in a folder based on a user's search criteria. The folder will grow throughout the year to over 1000 files, so rather than looping through all of them every time the macro runs, I would like to add a second criteria that compares the time stamps on the files to a time stamp saved on the file as the last time it was run. LastUpdateDate is set up as variable in date format at the top of the module, and the old timestamp is saved to it at the beginning of the code.
I tried this but it left me with a run time error. Is this doable using Do While, or is there another format I need to be looking at? I also tried nesting the date comparison as an if statement under the Do While, but came up with other errors.
Do While FileName <> "" and FileDateTime(FileName) > LastUpdateDate
Working code from this section:
FileName = Dir(FolderName & "*" & MyCriterion & "*" & ".xl??")
'Loop through all matching files
Do While FileName <> ""
'Open the next matching workbook
Workbooks.Open (FolderName & FileName)
Sheets("Report Data").Select
'Call GrabTheData
GrabTheData
'Close the workbook
Workbooks(FileName).Close savechanges:=False
'Get the name of the next match in folder
FileName = Dir
Loop
End Sub
Two things:
FileDateTime
FileDateTime requires the full file path, not just the file name
Loops and Conditions
Do While (condition) stops execution of the block when (condition) is no longer true.
That is, it will stop execution as soon as (condition) is false. I don't believe this is the intended behavior.
Put an If (condition) block within the loop itself. This will loop through every workbook that matches MyCriterion, but only operate on those that match (condition).
Example (with recommendations)
Sub GrabAllData(ByVal FolderName As String, ByVal MyCriterion As String)
Dim FileName As String
Dim LastUpdateDate As Date
Dim wb As Workbook
LastUpdateDate = ThisWorkbook.Worksheets("Parameters").Range("LastUpdateDate").Value 'Named Range called LastUpdateDate on sheet "Parameters" in ThisWorkbook
'Make sure FolderName ends in a backslash
If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
'Get matching files for MyCriterion
FileName = Dir(FolderName & "*" & MyCriterion & "*" & ".xl??")
'Loop through all matching files
Do While FileName <> ""
If FileDateTime(FolderName & FileName) > LastUpdateDate Then 'FileDateTime requires the full file path, not just the file name
'Open the next matching workbook - work with the workbook directly, rather than working with ActiveWorkbook, ActiveSheet and Selections
Set wb = Workbooks.Open(FileName:=FolderName & FileName, ReadOnly:=True)
'Call GrabTheData on the workbook
GrabTheData wb
'Close the workbook
wb.Close SaveChanges:=False
End If
'Get the name of the next match in folder
FileName = Dir
Loop
Set wb = Nothing
End Sub
Sub GrabTheData(ByRef wb As Workbook)
Dim wsOut As Worksheet, wsIn As Worksheet
Set wsOut = ThisWorkbook.Worksheets("Aggregated Data") 'Worksheet called "Aggregated Data" in ThisWorkbook
Set wsIn = wb.Worksheets("Report Data")
' ### Manipulate the data and write to wsOut, no need to work with Selections ###
End Sub

Resources