VBA To copy data from multiple workbooks into master sheet including source worksheet name

[miguel_z]

Hi everyone. I am a complete and absolute beginner in the VBA area and Id like to ask the community for help.

The problem regards an issue that has been discussed in several topics, some of them really old like this one:

VBA to copy data from multiple workbooks into master sheet

Hello Everyone! I have to copy data from 10+ workbooks and paste it into a master workbook. All the workbooks are located in a folder on my desktop: C:\Users\xbv\Desktop\group1 All the workbooks contain a sheet named 'appendix B', I have to open each workbook, go to sheet 'appendix B’, select...

www.mrexcel.com

but in my case there is additional task to be solved.

I need to copy data from multiple csv. files (each of them consist only one worksheet) to one master worksheet. At first I'd like to copy information from columns "B" to "D" and then I'd like to add to column "A" source worksheet name. And to do that with all csv. files...

I used code already generated by famous user @mumps (You're a real hero mumps!), but I really struggle with adding the source worksheet name.

Here is the first part of the code that works perfectly...:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Const strPath As String = "c:\Users\michal\Documents\Macro\"
    ChDir strPath
    strExtension = Dir("*.csv*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets(1).Range("A1:E" & LastRow).Copy wkbDest.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

May I ask for help?

many thanks in advance...

m.

 

[HaHoBe]

Hi miguel_z,

maybe try this code on a copy of the workbook that collects the data:

Sub CopyRange_140521()
'https://www.mrexcel.com/board/threads/vba-to-copy-data-from-multiple-workbooks-into-master-sheet-including-source-worksheet-name.1170899/
 
  Dim wkbSource       As Workbook
 
  Dim wksDest         As Worksheet
 
  Dim LastRow         As Long
  Dim lngRowData      As Long
 
  Dim strExtension    As String
 
  Const cstrPATH      As String = "c:\Users\michal\Documents\Macro\"
 
  Application.ScreenUpdating = False
  'setting an object to the worksheet to write to
  Set wksDest = ThisWorkbook.Sheets(1)
 
  strExtension = Dir(cstrPATH & "*.csv*")
 
  Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(cstrPATH & strExtension)
    With wkbSource
      LastRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      'additional line for getting the first row to write to
      lngRowData = wksDest.Range("B" & Rows.Count).End(xlUp).Row + 1
      'like mentioned in the text copy columns B to D
      .Sheets(1).Range("B1:D" & LastRow).Copy wksDest.Range("B" & lngRowData)
      'filling in the sheet name
      wksDest.Range("A" & lngRowData).Resize(LastRow, 1).Value = .Sheets(1).Name
      .Close savechanges:=False
    End With
    strExtension = Dir
  Loop
  
  Set wkbSource = Nothing
  Set wksDest = Nothing
  Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[miguel_z]

Thanks Holger! Your help is really appreciated. Your code works perfectly! I was able to pull into the master more than 60 000 rows using your macro.

Perhaps you could help me with the second part of my problem...

The worksheets that are being copied to the master file contain also additional portion of information - characteristics of a certain product.

These characteristics always have the same layout. Three columns.
First is the characteristic name e.g. modulation_4Nm (column F), then the value e.g. 4,52 (column G). characteristics unit e.g. Nm (column H) and the result e.g OK or NOK (column I).
The name of the characteristic is always the same, the layout is the same, but across different files the location changes - the starting column is different.

The final exercise is to define in the master file starting from column "M1" fixed names of the characteristics in the source worksheets and then let macro search source worksheet one by one, find the column that has the same name as name described in cell "M1" of the master file and copy three adjacent cells from the source worksheet to rows M N O to the master file with the first characteristic.

And the find another characteristic that has the name defined in the cell "P1" of the master file and copy three adjacent rows

Is this a complicated script or theoretically I need only a simple example of the code and then I would be able to replicate it to copy more than two characteristics?

Many thanks in advance for your reply....

 

[HaHoBe]

Hi miguel_z,

this is a different problem than copying fixed areas in the opening post (and hasn´t been mentioned there).

Sniplet may look like this

Dim varCol As Variant
Dim varHeaders As Variant
Dim lngCounter As Long

varHeaders = Array("M1", "P1")

For lngCounter = LBound(varHeaders) To UBound(varHeaders)
    varCol = Application.Match(Range(varHeaders(lngCounter)).Value, .Sheets(1).Rows(1), 0)
    If IsError(varCol) Then
      MsgBox "Couldn´t find '" & Range(varHeaders(lngCounter)).Value & "' in row 1", vbInformation, "Skipping copying"
    Else
      .Sheets(1).Cells(2, varCol).Resize(LastRow, 3).Copy wksDest.Range(Left(varHeaders(lngCounter), 1) & lngRowData)
    End If
Next lngCounter

Ciao,
Holger

 

[miguel_z]

Many thanks Holger for your help. Unfortunately Your code did not work. Perhaps I did not explain completely what is the second step of the exercise. I am not sure if I may continue in this thread or open a new one dedicated to the problem...

 

[HaHoBe]

Hi miguel_z,

in any case it would be difficult to find out what did not work. Can you be more specific about that? Did you implement the sniplet into the basic code or run it on it`s own?

Ciao,
Holger

 

[miguel_z]

Hi Holger, I tried to implement it to the original code. Here is the whole code:

Sub CopyRange_140521()
'https://www.mrexcel.com/board/threads/vba-to-copy-data-from-multiple-workbooks-into-master-sheet-including-source-worksheet-name.1170899/
 
  Dim wkbSource       As Workbook
 
  Dim wksDest         As Worksheet
 
  Dim LastRow         As Long
  Dim lngRowData      As Long
 
  Dim strExtension    As String
 
  Const cstrPATH      As String = "c:\Users\michal\Documents\\Macro\"
 
  Application.ScreenUpdating = False
  'setting an object to the worksheet to write to
  Set wksDest = ThisWorkbook.Sheets(1)
 
  strExtension = Dir(cstrPATH & "*.csv*")
 
  Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(cstrPATH & strExtension)
    With wkbSource
      LastRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      'additional line for getting the first row to write to
      lngRowData = wksDest.Range("A" & Rows.Count).End(xlUp).Row + 1
      'like mentioned in the text copy columns A to E
      .Sheets(1).Range("A1:E" & LastRow).Copy wksDest.Range("B" & lngRowData)
      'filling in the sheet name
      wksDest.Range("A" & lngRowData).Resize(LastRow, 1).Value = .Sheets(1).Name
     
     Dim varCol As Variant
     Dim varHeaders As Variant
     Dim lngCounter As Long
     
     varHeaders = Array("M1", "N1")

    For lngCounter = LBound(varHeaders) To UBound(varHeaders)
    varCol = Application.Match(Range(varHeaders(lngCounter)).Value, .Sheets(1).Rows(1), 0)
    If IsError(varCol) Then
      MsgBox "Couldn´t find '" & Range(varHeaders(lngCounter)).Value & "' in row 1", vbInformation, "Skipping copying"
    Else
      .Sheets(1).Cells(2, varCol).Resize(LastRow, 3).Copy wksDest.Range(Left(varHeaders(lngCounter), 1) & lngRowData)
    End If
Next lngCounter
     
     
      .Close savechanges:=False
    End With
    strExtension = Dir
  Loop
 
  Set wkbSource = Nothing
  Set wksDest = Nothing
  Application.ScreenUpdating = True

End Sub

It did pull out rows from the source worksheets but not based on the value of cell "M1" in the destination master file. Perhaps I did not explain correctly what is the second part of the exercise. I will try to explain again.

By the first part of the code that You have provided I have copied to the master destination file all the information located in the source worksheets that are COMMON to every single source files (columns B:F) plus in columns A we have the name of every source worksheets.

Now the final code could be even less difficult. Imagine that I want to copy 1 column from the source file that has a name "modulation_4Nm" in the first row of the source files.
I want to have all the information in column "M" of the master file, but in some source files the location of the column "modulation_4Nm" is in column "F", in other in colum "Q".

Can a macro search all the files and copy columns from every source file that has a name "modulation_4Nm" in the first row?

Thank you for your patience...

Michal

 

[HaHoBe]

Hi miguel_z

maybe give this macro a try:

Sub CopyRange_140521_03()
'https://www.mrexcel.com/board/threads/vba-to-copy-data-from-multiple-workbooks-into-master-sheet-including-source-worksheet-name.1170899/
 
  Dim wkbSource       As Workbook
 
  Dim wksDest         As Worksheet
 
  Dim LastRow         As Long
  Dim lngRowData      As Long
  Dim lngCounter      As Long
  
  Dim rngFound        As Range
 
  Dim strExtension    As String
  Dim strSearch       As String
  
  Dim varCol          As Variant
  Dim varHeaders      As Variant
      
  Const cstrPATH      As String = "c:\Users\michal\Documents\\Macro\"
 
  varHeaders = Array("M1", "P1")
 
  Application.ScreenUpdating = False
  'setting an object to the worksheet to write to
  Set wksDest = ThisWorkbook.Sheets(1)
 
  strExtension = Dir(cstrPATH & "*.csv*")
 
  Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(cstrPATH & strExtension)
    With wkbSource
      LastRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      'additional line for getting the first row to write to
      lngRowData = wksDest.Range("A" & Rows.Count).End(xlUp).Row + 1
      'like mentioned in the text copy columns A to E
      .Sheets(1).Range("A1:E" & LastRow).Copy wksDest.Range("B" & lngRowData)
      'filling in the sheet name
      wksDest.Range("A" & lngRowData).Resize(LastRow, 1).Value = .Sheets(1).Name

      For lngCounter = LBound(varHeaders) To UBound(varHeaders)
        strSearch = wksDest.Range(varHeaders(lngCounter)).Value
        Set rngFound = .Sheets(1).Rows(1).Find(strSearch, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
        If Not rngFound Is Nothing Then
          rngFound.Offset(1, 0).Resize(LastRow, 3).Copy wksDest.Range(varHeaders(lngCounter)).Offset(lngRowData - 1, 0)
          Set rngFound = Nothing
        End If
      Next lngCounter
      .Close savechanges:=False
    End With
    strExtension = Dir
  Loop
 
  Set wkbSource = Nothing
  Set wksDest = Nothing
  Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[miguel_z]

Great! It works! I was able to copy all the rows from more than 40 files that had values based on the "M1" cell.

This is the code:

Sub CopyRange_140521_03()
'https://www.mrexcel.com/board/threads/vba-to-copy-data-from-multiple-workbooks-into-master-sheet-including-source-worksheet-name.1170899/
 
  Dim wkbSource       As Workbook
 
  Dim wksDest         As Worksheet
 
  Dim LastRow         As Long
  Dim lngRowData      As Long
  Dim lngCounter      As Long
  
  Dim rngFound        As Range
 
  Dim strExtension    As String
  Dim strSearch       As String
  
  Dim varCol          As Variant
  Dim varHeaders      As Variant
 
  Const cstrPATH      As String = "c:\Users\michal.zima\Documents\Obszar2\S-PLATFORM 1\Makro\"
  
  varHeaders = Array("M1")
  'I have reduced the array to only one cell value - in this case M1
  
 
  Application.ScreenUpdating = False
  'setting an object to the worksheet to write to
  Set wksDest = ThisWorkbook.Sheets(1)
 
  strExtension = Dir(cstrPATH & "*.csv*")
 
  Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(cstrPATH & strExtension)
    With wkbSource
      LastRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      'additional line for getting the first row to write to
      lngRowData = wksDest.Range("A" & Rows.Count).End(xlUp).Row + 1
      'like mentioned in the text copy columns A to E
      .Sheets(1).Range("A1:E" & LastRow).Copy wksDest.Range("B" & lngRowData)
      'filling in the sheet name
      wksDest.Range("A" & lngRowData).Resize(LastRow, 1).Value = .Sheets(1).Name
      
     
    For lngCounter = LBound(varHeaders) To UBound(varHeaders)
        strSearch = wksDest.Range(varHeaders(lngCounter)).Value
        Set rngFound = .Sheets(1).Rows(1).Find(strSearch, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
        If Not rngFound Is Nothing Then
        rngFound.Offset(0, 0).Resize(LastRow, 1).Copy wksDest.Range(varHeaders(lngCounter)).Offset(lngRowData - 1, 0)
        'rngFound Offset changed to 0 as I copy also the first row
        
       
          Set rngFound = Nothing
        End If
     
      Next lngCounter
       .Close savechanges:=False
    End With
    strExtension = Dir
  Loop
 
  Set wkbSource = Nothing
  Set wksDest = Nothing
  Application.ScreenUpdating = True

End Sub

Two questions:

I wasn't able to replicate this code for more cell values (e.g. cell value N1 etc.)
How to change the range of the variable "rngFound : e.g. I want to look for column with the name "CURRENT_A1" but copy data from adjacent column...

Am I to work with this variable?:

 rngFound.Offset(0, 0).Resize(LastRow, 1).Copy wksDest.Range(varHeaders(lngCounter)).Offset(lngRowData - 1, 0)

Anyway, you're the best, Holger....

 

[HaHoBe]

Hi miguel_z,

the addresses of the cells which hold the values to search for in the columns are given in

 varHeaders = Array("M1", "P1")

This will take the values from the destination sheet in the given cells as well as serve for the address to copy to later.

In your code you used

  varHeaders = Array("M1")

There is no need for a loop for only one item but in case you want more I would indicate the cells address of the second or more item as given in my example.

The code is still basicly putting together the whole contents wanted into one sheet. It may be broken up to partials in order to add additional data to that already being collected but at present we should stick with this approach first and come to any alterations if wanted later on.

The range rngFound holds either the range of the cell with the item you searched for or Nothing if the item has not been found. As you stated before the second item to search for could be anywhere but not necessary in a certain distance or relation to the first one you should apply a second search for the second item instead of offsetting the object to a column which may not fit.

 rngFound.Offset(0, 0).Resize(LastRow, 1).Copy wksDest.Range(varHeaders(lngCounter)).Offset(lngRowData - 1, 0)

means take the cell we found, go down one row, make the area to copy 3 columns wide and the number of rows from the first block long including maybe a blank row. If there is additional data inside any of these columns (I can´t see any reason for that) you should reduce the number of rows to ...Resize(LastRow - 1, 3)...

Ciao,
Holger