Macro to open multiple workbooks and copy a range of data based on todays date. Then paste the data in master workbook in one sheet under each other.

[Luke1690]

Hi,

okay, so i have multiple workbooks all set out the same. Data in columns (B:K). In column (D) shows the date in this format 25/07/24.
i then have a master workbook set out the same way that i want to paste all the data from the induvial workbooks to daily, using the date showing in column (D)

For example , all sheets called sheet1

workbook 1 - (1) open workbook copy all rows of data that has todays date in column (d) - open master and pastes under previous data - close workbook1
workbook 2 - (3) open workbook copy all rows of data that has todays date in column (d) - pastes under previous data - close workbook2
workbook 3 - (4) open workbook copy all rows of data that has todays date in column (d) - pastes under previous data - close workbook3

master (2) workbook open workbook - once all data has been pasted, save and close master workbook.

Thank you in advance i know this one requires a lot of code.

 

[DanteAmor]

Hi @Luke1690

You left out some details that I'm going to assume.
- The data is on sheet 1, in all books and also in the master book.
- The data has a header in row 1.
- Data starts in row 2.
- Paste the data on sheet 1 of the master book, starting in column B.
- The master book is in a different folder than the folder where the other books are.

Considering the above, you must adjust the following data in the macro:

  sPathMaster = "C:\trabajo\"         'fit the folder name where the master workbook is
  sNameMaster = "masterworkbook.xlsx" 'fit the file name of the master workbook
  sPathFiles = "C:\trabajo\examples\" 'fit the folder name where the workbooks is

Put the following macro in a workbook and run it.

Sub Copy_Data_Today()
  Dim MasterWB As Workbook, wb2 As Workbook
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim sPathMaster As String, sNameMaster As String
  Dim sPathFiles As String, sFile As String
  Dim lr1 As Long, lr2 As Long
  
  Application.ScreenUpdating = False
  
  sPathMaster = "C:\trabajo\"         'fit the folder name where the master workbook is
  sNameMaster = "masterworkbook.xlsx" 'fit the file name of the master workbook
  sPathFiles = "C:\trabajo\examples\" 'fit the folder name where the workbooks is
  
  If Dir(sPathMaster & sNameMaster) = "" Then
    MsgBox "The master book does not exist, check the name"
    Exit Sub
  Else
    Set MasterWB = Workbooks.Open(sPathMaster & sNameMaster, False)
    Set sh1 = MasterWB.Sheets(1)
  End If
  
  sFile = Dir(sPathFiles & "*.xls*")
  Do While sFile <> ""
    Set wb2 = Workbooks.Open(sPathFiles & sFile, False, True)
    Set sh2 = wb2.Sheets(1)
  
    lr1 = sh1.Range("D" & Rows.Count).End(3).Row + 1
    lr2 = sh2.Range("D" & Rows.Count).End(3).Row
    
    sh2.Range("A1:D" & lr2).AutoFilter 4, Criteria1:=1, Operator:=11 ', Criteria2:=0, SubField:=0
    If sh2.Range("D" & Rows.Count).End(3).Row > 1 Then
      sh2.AutoFilter.Range.Range("B2:K" & lr2).Copy sh1.Range("B" & lr1)
    End If
  
    wb2.Close False
    sFile = Dir()
  Loop
  MasterWB.Close True
  Application.ScreenUpdating = True
  MsgBox "Process finished"
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

 

[Luke1690]

Hi Dante,

yes the statements above are correct , i knew I'd miss some information out.

As soon as i can get chance to test this out i will get back to you. ( Don't think I'm ignoring you, I'm grateful for your help)

Code looks ace fingers crossed.

Be in touch soon!

 

[Luke1690]

Hi Dante,

yes the statements above are correct , i knew I'd miss some information out.

As soon as i can get chance to test this out i will get back to you. ( Don't think I'm ignoring you, I'm grateful for your help)

Code looks ace fingers crossed.

Be in touch soon!

Hi Dante,

sorry for the late response ive only just got round to this.

so i have ran it a couple of times with no luck.

i have the master workbook open and run the macro from there.

i can see all the workbooks open and close but no data copies across, after the code has finished it closes the master and opens a new blank document workbook that has sort of crashed. i close that workbook and open the master (that hasn't saved) and there is no data.

again thanks for your help.

 

[Luke1690]

Hi Dante,

sorry for the late response ive only just got round to this.

so i have ran it a couple of times with no luck.

i have the master workbook open and run the macro from there.

i can see all the workbooks open and close but no data copies across, after the code has finished it closes the master and opens a new blank document workbook that has sort of crashed. i close that workbook and open the master (that hasn't saved) and there is no data.

again thanks for your help.

so i have noticed in the workbooks im copying from rows 1 has the title and 2/3 are merged with headers. so data starts from row4


master row 1 has the headers.

 

[DanteAmor]

so i have noticed in the workbooks im copying from rows 1 has the title and 2/3 are merged with headers. so data starts from row4

It would be great if you answered each of the assumptions I made in post #2.

It would also be very helpful if you gave a couple of examples of how the data is in each book and how you want it in the master book.
Use XL2BB tool to give the examples.

Observe in the following thread how the OP put his examples in detail and also explained how he wanted the result, in that way it was a great help and the macro was done in a single step.

extract data from the lastrow contains specific word based on date today

Hello I want to extract data for specific information with the formatting as in original sheets as I did it in REPORT sheet I want to extract for the DATE and INV.NO,TOTAL from each row contains SUM word based on date today . so in REPORT sheet should create sheet name in above as I did it...

www.mrexcel.com

 

[Luke1690]

Hi Dante,

Apologies for the confusion. i have replied to your question in red and shown examples

- The data is on sheet 1 ( No the data is on a sheet called (Rework) In the master it is on Sheet1

- The data has a header in row 1 (Please see the image below) only copy contents that has todays date in column D (Columns A:K) changing on the day.

- Data starts in row 2. (row 4 as seen above)
- Paste the data on sheet 1 of the master book, starting in column B. ( sheet1 Starting from column A)
- The master book is in a different folder than the folder where the other books are (yes)
paste the data under any previous data.

 

[DanteAmor]

Ok, the rules change.

1. Put the macro in your master book.

2. In the master book you must have a sheet called "Sheet1".

3. All the books to be loaded must be in a folder, which you must specify on this line: sPathFiles = "C:\trabajo\examples\"

4. All workbooks must have a sheet called "Rework".

5. The data starts in row 4.

6. The dates are in column D.

7. The data to be copied goes from column A to K.

8. The data is pasted after the last row with data from the Sheet1 sheet of the master book.


If all of the above is correct, then you should have no problems with the macro.

Sub Copy_Data_Today()
  Dim MasterWB As Workbook, wb2 As Workbook
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim sPathFiles As String, sFile As String
  Dim lr1 As Long, lr2 As Long
  
  Application.ScreenUpdating = False
  
  sPathFiles = "C:\trabajo\examples\" 'fit the folder name where the workbooks is

  Set MasterWB = ThisWorkbook
  Set sh1 = MasterWB.Sheets("Sheet1")
  
  sFile = Dir(sPathFiles & "*.xls*")
  Do While sFile <> ""
    Set wb2 = Workbooks.Open(sPathFiles & sFile, False, True)
    Set sh2 = wb2.Sheets("Rework")
  
    lr1 = sh1.Range("D" & Rows.Count).End(3).Row + 1
    lr2 = sh2.Range("D" & Rows.Count).End(3).Row
    
    sh2.Range("A3:K" & lr2).AutoFilter 4, Criteria1:=1, Operator:=11 ', Criteria2:=0, SubField:=0
    If sh2.Range("D" & Rows.Count).End(3).Row > 3 Then
      sh2.AutoFilter.Range.Range("A2:K" & lr2).Copy sh1.Range("A" & lr1)
    End If
  
    wb2.Close False
    sFile = Dir()
  Loop
  
  Application.ScreenUpdating = True
  MsgBox "Process finished"
End Sub

 

[Luke1690]

Ok, the rules change.

1. Put the macro in your master book.

2. In the master book you must have a sheet called "Sheet1".

3. All the books to be loaded must be in a folder, which you must specify on this line: sPathFiles = "C:\trabajo\examples\"

4. All workbooks must have a sheet called "Rework".

5. The data starts in row 4.

6. The dates are in column D.

7. The data to be copied goes from column A to K.

8. The data is pasted after the last row with data from the Sheet1 sheet of the master book.


If all of the above is correct, then you should have no problems with the macro.

Sub Copy_Data_Today()
  Dim MasterWB As Workbook, wb2 As Workbook
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim sPathFiles As String, sFile As String
  Dim lr1 As Long, lr2 As Long
 
  Application.ScreenUpdating = False
 
  sPathFiles = "C:\trabajo\examples\" 'fit the folder name where the workbooks is

  Set MasterWB = ThisWorkbook
  Set sh1 = MasterWB.Sheets("Sheet1")
 
  sFile = Dir(sPathFiles & "*.xls*")
  Do While sFile <> ""
    Set wb2 = Workbooks.Open(sPathFiles & sFile, False, True)
    Set sh2 = wb2.Sheets("Rework")
 
    lr1 = sh1.Range("D" & Rows.Count).End(3).Row + 1
    lr2 = sh2.Range("D" & Rows.Count).End(3).Row
   
    sh2.Range("A3:K" & lr2).AutoFilter 4, Criteria1:=1, Operator:=11 ', Criteria2:=0, SubField:=0
    If sh2.Range("D" & Rows.Count).End(3).Row > 3 Then
      sh2.AutoFilter.Range.Range("A2:K" & lr2).Copy sh1.Range("A" & lr1)
    End If
 
    wb2.Close False
    sFile = Dir()
  Loop
 
  Application.ScreenUpdating = True
  MsgBox "Process finished"
End Sub

Dante,

Thanks a lot works perfect.

Really appreciate your help