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.

 

[miguel_z]

Thanks for clarification. The whole code works including the array. I simply did as you told me - moved from

  varHeaders = Array("M1")

to

 varHeaders = Array("M1", "N1", "O1", "P1", "Q1", "R1", "S1", "T1", "U1", "V1", "W1", "X1", "Y1", "Z1")

.

I tried to increase the array to:

 varHeaders = Array("M1", "N1", "O1", "P1", "Q1", "R1", "S1", "T1", "U1", "V1", "W1", "X1", "Y1", "Z1", "AA1", AB1")

as I have more columns to import and it didn't work. It still copies only until "Z", instead it has overwritten column "A" in the master file :/

Is there a limitation to the amount of this function?

Also to answer your question why I need to copy 3 column to the right instead of the one that we are looking for: This is a screenshot of one of the source files:

As you can see - the structure of the source files is really weird - you can see columns "A", "B", "C", "D", "E" - those were pulled with the first part of the exercise. Remaining columns are those bloody characteristcs - so the macro looks for characteristic: "20_CW_Load1 4Nm\3CH3_CW_L1_Torque_Avarage" but in reality what counts is the column "I" - where is OK/NOK result of this characteristic. Hope that answers your doubts...

And the whole code is like this:

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", "N1", "O1", "P1", "Q1", "R1", "S1", "T1", "U1", "V1", "W1", "X1", "Y1", "Z1", "AA1")
 'increased amount of cells as there are more columns to import
 
  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, 3).Resize(LastRow, 1).Copy wksDest.Range(Left(varHeaders(lngCounter), 1) & lngRowData)
        'changed to copy third column instead of the searched one as this data is significant
        
          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

 

[HaHoBe]

Hi miguel_z,
where to start to answer...?

Let´s start with the overwriting of Column A. Clearly my mistake as I used the command

Left(varHeaders(lngCounter), 1)

which just allows one character to be used. You really need the value from fourth column where the item is found?

The offending line limiting the code to just run from Column A to Z is

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

I havent´t tested the code but this line should do fine

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

Ciao,
Holger

 

[miguel_z]

You got it! I wasn't clear on that part. So coming back to the example source worksheet:

You see - in fact, I am looking for a characteristic in columns "F" and "J", but what I really care about is the RESULT - the one in columns "I" for the first one, and "M" in the second one.

So my array in the master sheet starts at "M1" cell where I have written "20_CW_Load1 4Nm\3CH3_CW_L1_Torque_Avarage" but what I really need to pull there is the result located in the 3rd column to the right of the characteristic in the source file.

This is because the files are generated by the computer and I cannot modify them.
The layout of all the characteristics is always the same - four columns - name_characteristics(still the same across source worksheets), value, unit, OK/NOK result - but they tend to be "scattered" in different positions across different source worksheets...

I will test the proposed modification and let you know! Many thanks for your help!

 

[miguel_z]

@HaHoBe Holger, code tested with 54 columns and 62 000 rows imported to master file. Everything works perfectly. It took 10 min on 100% CPU to copy everyting but it's done!

This is the final code in case someone would need it in the future. (I included additional sub to clear rows and columns before the start...)

Sub Clear_Table()

   Range("A2:F" & Rows.Count).ClearContents
    
   Range("M2:BN" & Rows.Count).ClearContents
   
End Sub

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", "N1", "O1", "P1", "Q1", "R1", "S1", "T1", "U1", "V1", "W1", "X1", "Y1", "Z1", "AA1", "AB1", "AC1", "AD1", "AE1", "AF1", "AG1", "AH1", "AI1", "AJ1", "AK1", "AL1", "AM1", "AN1", "AO1", "AP1", "AQ1", "AR1", "AS1", "AT1", "AU1", "AV1", "AW1", "AX1", "AY1", "AZ1", "BA1", "BB1", "BC1", "BD1", "BE1", "BF1", "BG1", "BH1", "BI1", "BJ1", "BK1", "BL1", "BM1", "BN1")
 'increased amount of cells as there are more columns to import
 
  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, 3).Resize(LastRow, 1).Copy wksDest.Range(varHeaders(lngCounter)).Offset(lngRowData - 1, 0)
        'changed to copy third column instead of the searched one as this data is significant
        
          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

Once again, I don't know how to thank you! Your help is really appreciated! Many thanks for your support!

regards
m.

 

[HaHoBe]

Hi miguel_z,

if there are formulas involved you could try to set the Calculation to manual for the run of the macro and turn off events if there are any ecents behind the sheet. You might as well try to minimze the instance to the statusbar but I doubt that to be a great help. You should always make sure that the measures are put back the normal values in case any error occurs.

Thanks for the feedback.

Ciao,
Holger