Macro to copy cells from multiple excels in a folder that changes name daily

C

cdalgorta

Board Regular
Joined
Jun 5, 2022
Messages
87
Office Version
  1. 365
Platform
  1. Windows
Happy holidays! And thank you in advance!

In summary: I need a macro that would copy all the columns A:C starting from Row 2 if the sheet name is "Apply" or "apply", of all the excels in a specific folder. I need to paste all these values on another Excel.

Example:

Specific folder(changes daily):
1672071869647.png


I need to copy A:C starting from Row 2 of all the excels in the above folder(If the sheet name is "Apply" or "apply").
1672070735292.png
1672070742231.png


I need to paste them(as value) all in the below excel(name changes daily). On the sheet name "Paid Invoices" and paste them on the same cells "A:C" all the way down:
1672071025628.png


By the way, I'm not sure how much more complicated it would be to make a macro for this because of the folder name I need to copy from changes daily, so if that's the complicated part, I wouldn't mind having to copy/paste all the excels from the changing folder into a standard folder in my desktop(name can be "Daily Change").
1672071397324.png



Action:

In a perfect world(hahah), I'd say that what I'd need is to open this Excel:
1672071517269.png


Click on the macro, and the macro would first ask me to choose the folder from which I want to copy from and I'd choose the one I need:
1672071700572.png


The macro would then do the rest by copying and pasting(as value) the cells that I need. A:C starting from row 2 of sheet named "Apply" or "apply.
1672071781434.png


Thank you!

P.S. I can have the macro on the personal macro workbook, or it would probably be better if I can have it on the excel that is getting the information pasted on. In this example, it would be in this one:
1672072583600.png

The above is always a new copy(with the new dates) of the primary template(below). So I could paste the VBA on the template macro.
1672072674145.png
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
Hi there. This should do it when added to a new normal module of the destination workbook, which would be your "ACH 12.27 (12.23 info).xlsm" file.

As explained below, I assumed that the lookback into the invoice folder is always four days as your example has the paste to workbook as 12/27 and the invoice folder as 12/23.

VBA Code: 
Sub ImportInvoices()

'declare Active WB (destination workbook) and Paid Invoices tab
Dim wb As Workbook: Set wb = ThisWorkbook
Dim pi As Worksheet: Set pi = wb.Sheets("Paid Invoices")

'determines correct month and year of folder to go through
'Note: The "- 4" is from the 12/27 to 12/23 example (i.e.; 4 day difference)
Dim iMon As Integer, iYear As Integer
If Not Month(Date - 4) = Month(Date) Then
    iMon = Month(Date) - 1
Else
    iMon = Month(Date)
End If
If Not Year(Date - 4) = Year(Date) Then
    iYear = Year(Date) - 1
Else
    iYear = Year(Date)
End If

'declare variables for folders (invoice path)
Dim iPath As String: iPath = "G:\Shared drives\AP-AR\AR\Bank Deposits\" & _
    iYear & "\" & iMon & "-" & iYear & "\" & "Remittances" & "\" & iMon & _
    "-" & Day(Date - 4) & " Remittances" & "\"

'Optimize processing
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

On Error GoTo ResetSettings

'set up loop through iPath
Dim iExt As String: iExt = "*.xls*"
Dim iFile As String: iFile = Dir(iPath & iExt)
Dim iWB As Workbook, iWBLR As Long, piLR As Long

'loop through each excel file in iPath
Do While iFile <> ""
    Set iWB = Workbooks.Open(Filename:=iFile, ReadOnly:=True)
    DoEvents
    
    If WSExists("Apply") = True Or WSExists("apply") = True Then
        'determine last row of Apply sheet and next open row of Paid Invoices (pi) sheet
        iWBLR = iWB.Sheets("Apply").Cells(iWB.Sheets("Apply").Rows.Count, 1).End(xlUp).Row
        piLR = pi.Cells(pi.Rows.Count, 1).End(xlUp).Row + 1
        'converts any formulas in range form Apply sheet to values
        Dim c As Range
        For Each c In iWB.Sheets("Apply").Range("A2:C" & iWBLR).Cells
            If c.HasFormula Then c.Formula = c.Value
        Next c
        'copies range from Apply sheet to Paid Invoices sheet
        iWB.Sheets("Apply").Range("A2:C" & iWBLR).Copy pi.Cells(piLR, 1)
    End If
    
    DoEvents
    iWB.Close savechanges:=False
    iFile = Dir
Loop

'Restores settings
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

'Task completion message
MsgBox "The task has completed.", vbInformation, "Task Completion"

Exit Sub

'Error Handling
ResetSettings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Function WSExists(SheetName As String) As Boolean
    
Dim TempSheetName As String

TempSheetName = UCase(SheetName)

WSExists = False
    
For Each Sheet In Worksheets
    If TempSheetName = UCase(Sheet.Name) Then
        WSExists = True
        Exit Function
    End If
Next Sheet

End Function
 
Upvote 0
Hi. Thank you for the quick reply!
I got this error. Is it because some files have parenthesis?
1672077886007.png



Also, is not always 4 days. It's pretty much the next day the bank is open. So if it's tomorrow for wednesday, then the file name would be "ACH 12.28 (12.27 info).xlsm". Except Fridays(3 day difference), the other days is always 1 day difference(today banks are close so it ended up being 4 days).
Would I just need to change the below part to "-1" to make it work and then change it to "-3" on Fridays?

VBA Code: 
'determines correct month and year of folder to go through
'Note: The "- 4" is from the 12/27 to 12/23 example (i.e.; 4 day difference)
Dim iMon As Integer, iYear As Integer
If Not Month(Date - 4) = Month(Date) Then    'Change to -1 Mon to Th and -3 on Fri
    iMon = Month(Date) - 1
Else
    iMon = Month(Date)
End If
If Not Year(Date - 4) = Year(Date) Then           'Change to -1 Mon to Th and -3 on Fri
    iYear = Year(Date) - 1
Else
    iYear = Year(Date)
End If
 
Upvote 0
Actually, I just realized that it grabbed a file from the 12-22 folder instead of the 12-23 folder.
 
Upvote 0
Okay, we can use the workday function to determine the previous workday. As for the file error, I found an issue with the workbooks.open part, which was missing the folder path.

The previous workday option might not be the best when considering holidays. A range of holidays could be added somewhere in your file where the previous workday would then consider holidays. Or, using the folder picker dialog to manually select the correct folder would be another option. Let me know how the below works or if you'd just like to manually pick the correct folder every time.

VBA Code: 
Sub ImportInvoices()

'declare Active WB and Paid Invoices tab
Dim wb As Workbook: Set wb = ThisWorkbook
Dim pi As Worksheet: Set pi = wb.Sheets("Paid Invoices")

'determines the previous workday
Dim lb As Date: lb = CDate(Evaluate("WORKDAY(TODAY(),-1)"))

'declare variables for folders (invoice path)
Dim iPath As String: iPath = "G:\Shared drives\AP-AR\AR\Bank Deposits\" & _
    Year(lb) & "\" & Month(lb) & "-" & Year(lb) & "\" & "Remittances" & "\" _
    & Month(lb) & "-" & Day(lb) & " Remittances" & "\"

'Optimize processing
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

On Error GoTo ResetSettings

'set up loop through iPath
Dim iExt As String: iExt = "*.xls*"
Dim iFile As String: iFile = Dir(iPath & iExt)
Dim iWB As Workbook, iWBLR As Long, piLR As Long

'loop through each excel file in iPath
Do While iFile <> ""
    Set iWB = Workbooks.Open(Filename:=iPath & iFile, ReadOnly:=True)
    DoEvents
    
    If WSExists("Apply") = True Or WSExists("apply") = True Then
        'determine last row of Apply sheet and next open row of Paid Invoices (pi) sheet
        iWBLR = iWB.Sheets("Apply").Cells(iWB.Sheets("Apply").Rows.Count, 1).End(xlUp).Row
        piLR = pi.Cells(pi.Rows.Count, 1).End(xlUp).Row + 1
        'converts any formulas in range form Apply sheet to values
        Dim c As Range
        For Each c In iWB.Sheets("Apply").Range("A2:C" & iWBLR).Cells
            If c.HasFormula Then c.Formula = c.Value
        Next c
        'copies range from Apply sheet to Paid Invoices sheet
        iWB.Sheets("Apply").Range("A2:C" & iWBLR).Copy pi.Cells(piLR, 1)
    End If
    
    DoEvents
    
    iWB.Close savechanges:=False
    iFile = Dir

Loop

'Restores settings
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

'Task completion message
MsgBox "The task has completed.", vbInformation, "Task Completion"

Exit Sub

'Error Handling
ResetSettings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Function WSExists(SheetName As String) As Boolean
    
Dim TempSheetName As String

TempSheetName = UCase(SheetName)

WSExists = False
    
For Each Sheet In Worksheets
    If TempSheetName = UCase(Sheet.Name) Then
        WSExists = True
        Exit Function
    End If
Next Sheet

End Function
 
Upvote 0
This worked perfectly! I made a sheet with the holidays, and tried to changed the below to add the list of holidays, but got a big error hahah
1672081297027.png

Tried changing this:
VBA Code: 
'determines the previous workday
Dim lb As Date: lb = CDate(Evaluate("WORKDAY(TODAY(),-1)"))

to this
VBA Code: 
Dim lb As Date: lb = CDate(Evaluate("=WORKDAY(TODAY(),-1,Hol!R2C2:R12C3)"))


And got error
1672082202079.png



Also, could you give me the option to get the "folder picker dialog to manually select the correct folder" please?
I just realized that the previous VBA will only work if I run it on the business day after the folder name date, but I sometimes work on it on the same day as the folder name to advance with my work at night(like the example I gave you, it's for the 27th, but I advanced it on the 23rd). It's called 27th because I cannot apply it in our system until that day, but the excel I can have it ready in advance which I like to do in the evening of the previous day hahah. This is why I think choosing the folder would probably be better. Sorry for the inconvenience!
 
Upvote 0
The below should allow you to use the folder picker option. For the workday formula, not sure if evaluate doesn't like the R1C1 style reference, but I was able to get it with the A1 style.

VBA Code: 
Sub ImportInvoices()

'declare Active WB and Paid Invoices tab
Dim wb As Workbook: Set wb = ThisWorkbook
Dim pi As Worksheet: Set pi = wb.Sheets("Paid Invoices")
'declares folder picker as a variable
Dim fPicker As FileDialog: Set fPicker = Application.FileDialog(msoFileDialogFolderPicker)

With fPicker
    .AllowMultiSelect = False
    .Title = "Select Invoice Folder"
    .Show
    If .SelectedItems.Count = 0 Then Exit Sub
End With

'Optimize processing
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

On Error GoTo ResetSettings

'set up loop through iFolder
Dim iFolder As String: iFolder = fPicker.SelectedItems(1) & "\"
Dim iExt As String: iExt = "*.xls*"
Dim iFile As String: iFile = Dir(iFolder & iExt)
Dim iWB As Workbook, iWBLR As Long, piLR As Long

'loop through each excel file in iFolder
Do While iFile <> ""
    Set iWB = Workbooks.Open(Filename:=iFolder & iFile, ReadOnly:=True)
    DoEvents
   
    If WSExists("Apply") = True Or WSExists("apply") = True Then
        'determine last row of Apply sheet and next open row of Paid Invoices (pi) sheet
        iWBLR = iWB.Sheets("Apply").Cells(iWB.Sheets("Apply").Rows.Count, 1).End(xlUp).Row
        piLR = pi.Cells(pi.Rows.Count, 1).End(xlUp).Row + 1
        'converts any formulas in range form Apply sheet to values
        Dim c As Range
        For Each c In iWB.Sheets("Apply").Range("A2:C" & iWBLR).Cells
            If c.HasFormula Then c.Formula = c.Value
        Next c
        'copies range from Apply sheet to Paid Invoices sheet
        iWB.Sheets("Apply").Range("A2:C" & iWBLR).Copy pi.Cells(piLR, 1)
    End If
   
    DoEvents
    iWB.Close savechanges:=False
    iFile = Dir
Loop

'Restores settings
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

'Task completion message
MsgBox "The task has completed.", vbInformation, "Task Completion"

Exit Sub

'Error Handling
ResetSettings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Function WSExists(SheetName As String) As Boolean
   
Dim TempSheetName As String

TempSheetName = UCase(SheetName)

WSExists = False
   
For Each Sheet In Worksheets
    If TempSheetName = UCase(Sheet.Name) Then
        WSExists = True
        Exit Function
    End If
Next Sheet

End Function
 
Upvote 0
Solution
Thank you so much! It works so well! This will save me 30-45 minutes daily of dozens and dozens of opening and closing files. 😭
Thank you again! And happy holidays! 🎄
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
847
Micron
M
N
  • Question Question
VBA to add title from formula to a save as name
Replies
0
Views
95
NKUNZI
N
H
  • Question Question
selecting a folder and copying all files into another folder
2 3
Replies
20
Views
496
Holley
H
Y
  • Question Question
Consolidate all values from specific sheets into 1 master excel file
Replies
1
Views
177
Trebor76
T
M
  • Question Question
Copy File Names to Destination File
Replies
2
Views
316
metalscuba
M

Forum statistics

Threads
1,223,882
Messages
6,175,164
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top