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.
Related
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!
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.
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
Not sure why I am getting this error. Please assist in correcting and also, provide a good explanation for the reason. I have 3 subs (from 2 modules) that call each other sequentially. Is the reason for the error message because the file name from the first sub is declared as a variable in the third sub? See code below:
Module1:
Option Explicit
Sub PRM_1_Report_Save()
'
Application.ScreenUpdating = False
Dim PRM_1_New As Workbook ' This is BCRS-PTASKS Unassigned.csv
Set PRM_1_New = Workbooks("BCRS-PTASKS Unassigned.csv")
Dim SaveDir1 As String, prmAfn As String
SaveDir1 = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
If Len(Dir(SaveDir1, vbDirectory)) = 0 Then MkDir SaveDir1
prmAfn = SaveDir1 & "\PRM_1_TEMP"
Application.SendKeys ("~")
PRM_1_New.SaveAs Filename:=prmAfn, FileFormat:=xlOpenXMLWorkbook
PRM_1_New.Close False
Call PRM_2_Report_Save
Application.ScreenUpdating = True
End Sub
Sub PRM_2_Report_Save()
'
Application.ScreenUpdating = False
Dim PRM_2_New As Workbook ' This is Problem WGM & WGL xref with description.xls
Set PRM_2_New = Workbooks("Problem WGM & WGL xref with description.xls")
Dim SaveDir2 As String, prmBfn As String
SaveDir2 = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
If Len(Dir(SaveDir2, vbDirectory)) = 0 Then MkDir SaveDir2
prmBfn = SaveDir2 & "\PRM_2_TEMP"
Application.SendKeys ("~")
PRM_2_New.SaveAs Filename:=prmBfn, FileFormat:=xlOpenXMLWorkbook
PRM_2_New.Close False
Application.ScreenUpdating = True
Call Open_PRM_Files
End Sub
Module 2:
Option Explicit
Sub Open_PRM_Files()
'
Application.ScreenUpdating = False
Dim PRM_Dir As String
Dim PRM_1_TEMP As Workbook
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx") ' This is the line that get's the error
Dim PRM_2_TEMP As Workbook
Set PRM_2_TEMP = Workbooks("PRM_2_TEMP.xlsx")
PRM_Dir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_1_TEMP
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_2_TEMP
Application.ScreenUpdating = True
End Sub
This line from the sub in Module2 is where the debugger shows the error (which is also commented in the sub above):
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx")
The purpose of the code here is to save two imported reports into .xlsx format, close them, and then open the files in the saved format. I need this to occur in separate subs (save and open) for other workflow processes of this VBA Project not listed (or relevant) here.
EDIT: I should also mention that the first two subs execute and provide the intended results which is each file saved in the new directory and with the proper extension.
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx")
This line assumes that you already have an open workbook with that name. If Excel does not find an open workbook with that name then you will get a runtime error as you noticed.
I'm assuming that you are trying to open the workbooks here which you created in the first two subs:
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_1_TEMP
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_2_TEMP
"& PRM_1_TEMP" is the name of a Workbook variable, and you're trying to concatenate it as a string name. Change this to a string matching the filename, and then move your declarations of workbooks to below the code that opens the workbooks. This way Excel opens the workbooks BEFORE trying to access them in the Workbooks collection, and you should not receive an error. I haven't tested this modification, but please let me know if it works for you.
Sub Open_PRM_Files()
Application.ScreenUpdating = False
Dim PRM_Dir As String
PRM_Dir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
Workbooks.Open Filename:=PRM_Dir & "\" & "PRM_1_TEMP"
Workbooks.Open Filename:=PRM_Dir & "\" & "PRM_2_TEMP"
Dim PRM_1_TEMP As Workbook
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx") ' This is the line that get's the error
Dim PRM_2_TEMP As Workbook
Set PRM_2_TEMP = Workbooks("PRM_2_TEMP.xlsx")
Application.ScreenUpdating = True
End Sub
I want to collect data from different files and insert it into a workbook doing something like this.
Do While THAT_DIFFERENT_FILE_SOMEWHERE_ON_MY_HDD.Cells(Rand, 1).Value <> "" And Rand < 65536
then 'I will search if the last row in my main worksheet is in this file...
End Loop
If the last row from my main worksheet is in the file, I'll quit the While Loop. If not, I'll copy everything. I'm having trouble finding the right algorithm for this.
My problem is that I don't know how to access different workbooks.
The best (and easiest) way to copy data from a workbook to another is to use the object model of Excel.
Option Explicit
Sub test()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet2").Range("C3:D4").Value = wb.Worksheets("Sheet1").Range("A1:B2").Value
End Sub
You might like the function GetInfoFromClosedFile()
Edit: Since the above link does not seem to work anymore, I am adding alternate link 1 and alternate link 2 + code:
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "" Then wbPath = wbPath & ""
If Dir(wbPath & "" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Are you looking for the syntax to open them:
Dim wkbk As Workbook
Set wkbk = Workbooks.Open("C:\MyDirectory\mysheet.xlsx")
Then, you can use wkbk.Sheets(1).Range("3:3") (or whatever you need)
There's very little reason not to open multiple workbooks in Excel. Key lines of code are:
Application.EnableEvents = False
Application.ScreenUpdating = False
...then you won't see anything whilst the code runs, and no code will run that is associated with the opening of the second workbook. Then there are...
Application.DisplayAlerts = False
Application.Calculation = xlManual
...so as to stop you getting pop-up messages associated with the content of the second file, and to avoid any slow re-calculations. Ensure you set back to True/xlAutomatic at end of your programming
If opening the second workbook is not going to cause performance issues, you may as well do it. In fact, having the second workbook open will make it very beneficial when attempting to debug your code if some of the secondary files do not conform to the expected format
Here is some expert guidance on using multiple Excel files that gives an overview of the different methods available for referencing data
An extension question would be how to cycle through multiple files contained in the same folder. You can use the Windows folder picker using:
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .Selected.Items.Count = 1 the InputFolder = .SelectedItems(1)
End With
FName = VBA.Dir(InputFolder)
Do While FName <> ""
'''Do function here
FName = VBA.Dir()
Loop
Hopefully some of the above will be of use
I had the same question but applying the provided solutions changed the file to write in. Once I selected the new excel file, I was also writing in that file and not in my original file. My solution for this issue is below:
Sub GetData()
Dim excelapp As Application
Dim source As Workbook
Dim srcSH1 As Worksheet
Dim sh As Worksheet
Dim path As String
Dim nmr As Long
Dim i As Long
nmr = 20
Set excelapp = New Application
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
.Show
path = .SelectedItems.Item(1)
End With
Set source = excelapp.Workbooks.Open(path)
Set srcSH1 = source.Worksheets("Sheet1")
Set sh = Sheets("Sheet1")
For i = 1 To nmr
sh.Cells(i, "A").Value = srcSH1.Cells(i, "A").Value
Next i
End Sub
With excelapp a new application will be called. The with block sets the path for the external file. Finally, I set the external Workbook with source and srcSH1 as a Worksheet within the external sheet.