Hi all, I'm trying to fix my vba code and am stuck on how to proceed.
I currently have a workbook "Master.xlsm" together with 5 .xlsx files in a folder. This Master file runs a macro that extracts data from the other files. This is working fine for .xlsx files but not for .xlsm files. The code is:
Sub Copy()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Dim LastRow As Long
Dim strPath As String
Dim strExtension As String
Dim Passwords As Object
' Set the path to the directory containing the workbooks
strPath = "C:\Users\NAME\Desktop\vba\"
' Create a dictionary to store workbook passwords
Set Passwords = CreateObject("Scripting.Dictionary")
Passwords("1.xlsx") = "password1"
Passwords("2.xlsx") = "password2"
Passwords("3.xlsx") = "password3"
Passwords("4.xlsx") = "password4"
Passwords("5.xlsx") = "password5"
Passwords("6.xlsm") = "password6"
' Add more workbooks and passwords as needed
Set wkbDest = ThisWorkbook
' Clear previous input data from the Master sheet (excluding header)
With wkbDest.Sheets("Master")
If .UsedRange.Rows.Count > 1 Then
.Rows("2:" & .Rows.Count).ClearContents
End If
End With
strExtension = Dir(strPath & "*.xlsx*")
' Remove the line that disables macros temporarily
' Application.AutomationSecurity = msoAutomationSecurityForceDisable
Do While strExtension <> ""
' Debugging: Print the workbook being processed
Debug.Print "Opening workbook: " & strExtension
On Error Resume Next
Set wkbSource = Workbooks.Open(strPath & strExtension, , , , Passwords(strExtension))
On Error GoTo 0 ' Turn off error handling
If wkbSource Is Nothing Then
MsgBox "Failed to open workbook: " & strExtension
Else
With wkbSource
' Debugging: Print the sheet name
Debug.Print "Sheet name: " & .Sheets("Sheet1").Name
LastRow = .Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Sheets("Sheet1").Range("A2:O" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
' Close the source workbook
.Close SaveChanges:=False
End With
End If
strExtension = Dir
Loop
' Save the destination workbook with today's date in ISO format
'Dim SavePath As String
'Dim TodayISO As String
' Get today's date in ISO format (YYYY-MM-DD)
'TodayISO = Format(Date, "yyyy-mm-dd")
' Set the save path to the same folder as the source workbooks
'SavePath = ThisWorkbook.Path & "\" & TodayISO & " Database.xlsm"
' Save the destination workbook with a password (use TodayISO as the password)
'wkbDest.SaveAs Filename:=SavePath, FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:=TodayISO
' Debugging: Print a message to indicate successful completion
Debug.Print "Data extraction and saving completed successfully."
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description
Application.ScreenUpdating = True
End Sub
However as you can see I hope to have an .xlsm file in the folder too which I would like to extract data from but this does not work. No error messages per so but just won't extract the data. I thought it might be an automatic macro in the .xlsm file blocking extraction of data but I have tried this with an .xlsm file with no running macros and this will not work. Nothing happens. Does anyone have a solution to use the above code to extract data from an .xlsm file? And if this .xlsm file is running an automatic macro how to extract data from this too?
I currently have a workbook "Master.xlsm" together with 5 .xlsx files in a folder. This Master file runs a macro that extracts data from the other files. This is working fine for .xlsx files but not for .xlsm files. The code is:
Sub Copy()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Dim LastRow As Long
Dim strPath As String
Dim strExtension As String
Dim Passwords As Object
' Set the path to the directory containing the workbooks
strPath = "C:\Users\NAME\Desktop\vba\"
' Create a dictionary to store workbook passwords
Set Passwords = CreateObject("Scripting.Dictionary")
Passwords("1.xlsx") = "password1"
Passwords("2.xlsx") = "password2"
Passwords("3.xlsx") = "password3"
Passwords("4.xlsx") = "password4"
Passwords("5.xlsx") = "password5"
Passwords("6.xlsm") = "password6"
' Add more workbooks and passwords as needed
Set wkbDest = ThisWorkbook
' Clear previous input data from the Master sheet (excluding header)
With wkbDest.Sheets("Master")
If .UsedRange.Rows.Count > 1 Then
.Rows("2:" & .Rows.Count).ClearContents
End If
End With
strExtension = Dir(strPath & "*.xlsx*")
' Remove the line that disables macros temporarily
' Application.AutomationSecurity = msoAutomationSecurityForceDisable
Do While strExtension <> ""
' Debugging: Print the workbook being processed
Debug.Print "Opening workbook: " & strExtension
On Error Resume Next
Set wkbSource = Workbooks.Open(strPath & strExtension, , , , Passwords(strExtension))
On Error GoTo 0 ' Turn off error handling
If wkbSource Is Nothing Then
MsgBox "Failed to open workbook: " & strExtension
Else
With wkbSource
' Debugging: Print the sheet name
Debug.Print "Sheet name: " & .Sheets("Sheet1").Name
LastRow = .Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Sheets("Sheet1").Range("A2:O" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
' Close the source workbook
.Close SaveChanges:=False
End With
End If
strExtension = Dir
Loop
' Save the destination workbook with today's date in ISO format
'Dim SavePath As String
'Dim TodayISO As String
' Get today's date in ISO format (YYYY-MM-DD)
'TodayISO = Format(Date, "yyyy-mm-dd")
' Set the save path to the same folder as the source workbooks
'SavePath = ThisWorkbook.Path & "\" & TodayISO & " Database.xlsm"
' Save the destination workbook with a password (use TodayISO as the password)
'wkbDest.SaveAs Filename:=SavePath, FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:=TodayISO
' Debugging: Print a message to indicate successful completion
Debug.Print "Data extraction and saving completed successfully."
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description
Application.ScreenUpdating = True
End Sub
However as you can see I hope to have an .xlsm file in the folder too which I would like to extract data from but this does not work. No error messages per so but just won't extract the data. I thought it might be an automatic macro in the .xlsm file blocking extraction of data but I have tried this with an .xlsm file with no running macros and this will not work. Nothing happens. Does anyone have a solution to use the above code to extract data from an .xlsm file? And if this .xlsm file is running an automatic macro how to extract data from this too?
