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!
Related
I have multiple workbooks in a folder #1 and I'm trying to copy certain cells information from one worbook to another.
The source files in the folder are .xslm and named "1" "2" "3".... etc
The target files (which I'm trying to copy the cells to) are in another folder are .csv and named "1" "2" "3".... etc
I have about 1000 files that I'm trying information from. so copying them one by one will take me forever
Source File Screenshot
Target File Screenshot
Assuming the files you want to copy from are in a folder C:\MyExcelFiles\ and assuming they are named 1.xlsm, 2.xlsm and the output files should be 1.xls and 2.xls, then it is a straight forward thing to do:
Sub CopyMacro()
Dim SourceFolder As String
Dim SourceFileName As String
Dim DestinationFileName As String
Dim SourceWorkbook As String
Dim DestinationWorkbook As String
SourceFolder = "C:\MyExcelFiles\"
Application.DisplayAlerts = False ' avoid security warning
For I = 1 To 100
SourceFileName = SourceFolder & I & ".xlsm"
DestinationFileName = SourceFolder & I & ".xls" ' could be any other file
On Error Resume Next
Workbooks.Open SourceFileName, ReadOnly:=True
If Err > 0 Then
MsgBox "Could not open file :" & SourceFileName
Exit Sub
End If
SourceWorkbook = ActiveWorkbook.Name
On Error GoTo 0
ActiveWorkbook.Sheets(1).Activate ' assuming the data you want to copy is on the first sheet
Range("a1:d6").Copy
Workbooks.Add
DestinationWorkbook = ActiveWorkbook.Name
Range("a1").PasteSpecial xlPasteValues
Workbooks(DestinationWorkbook).SaveAs DestinationFileName
ActiveWorkbook.Close
Workbooks(SourceWorkbook).Close
DoEvents ' give a chance for mouse events and keyboard events to get executed
' this will also allow you to press CTRL+PAUSE if you want to stop the macro
Next
Application.DisplayAlerts = True 'Switch alerts back on
End Sub
Please keep in mind, I did not test the code. But I am sure you will be able to fix it if it has any bugs, or errors.
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.
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.
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.
I am importing a batch of csv files from a folder all in separate worksheets, yet when I import the file, my new data loses leading zeroes for numbers and also loses its UTF-8 format. Is there any possible way to import the csv files while keeping leading zeroes and UTF-8 format?
Below is my vba
Option Explicit
Sub ImportCSVs()
Dim fPath As String
Dim fCSV As String
Dim wbCSV As Workbook
Dim wbMST As Workbook
Set wbMST = ThisWorkbook
fPath = "C:\mycsvfiles\Q3 2017\" 'path to CSV files, include the final \
Application.ScreenUpdating = False 'speed up macro
Application.DisplayAlerts = False 'no error messages, take default answers
fCSV = Dir(fPath & "*.csv") 'start the CSV file listing
On Error Resume Next
Do While Len(fCSV) > 0
Set wbCSV = Workbooks.Open(fPath & fCSV) 'open a CSV file
wbMST.Sheets(ActiveSheet.Name).Delete 'delete sheet if it exists
ActiveSheet.Move After:=wbMST.Sheets(wbMST.Sheets.Count) 'move new sheet into Mstr
Columns.AutoFit 'clean up display
fCSV = Dir 'ready next CSV
Loop
Application.ScreenUpdating = True
Set wbCSV = Nothing
End Sub
Thanks a million in advance! Let me know if I can provide additional information