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

miguel_z

New Member
Joined
May 13, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
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:


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...:

VBA Code:
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

New Member
Joined
May 13, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
Thanks for clarification. The whole code works including the array. I simply did as you told me - moved from
VBA Code:
  varHeaders = Array("M1")
to
VBA Code:
 varHeaders = Array("M1", "N1", "O1", "P1", "Q1", "R1", "S1", "T1", "U1", "V1", "W1", "X1", "Y1", "Z1")
.

I tried to increase the array to:
VBA Code:
 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:

1621277415218.png


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:

VBA 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\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
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

HaHoBe

Active Member
Joined
Jan 24, 2003
Messages
474
Office Version
  1. 2013
Platform
  1. Windows
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
Code:
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
Code:
        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
Code:
        rngFound.Offset(0, 3).Resize(LastRow, 1).Copy wksDest.Range(varHeaders(lngCounter)).Offset(lngRowData - 1, 0)
Ciao,
Holger
 
Last edited:

miguel_z

New Member
Joined
May 13, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
You got it! I wasn't clear on that part. So coming back to the example source worksheet:

1621279408010.png

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

New Member
Joined
May 13, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
@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...)

VBA Code:
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

Active Member
Joined
Jan 24, 2003
Messages
474
Office Version
  1. 2013
Platform
  1. Windows
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
 

Forum statistics

Threads
1,136,630
Messages
5,676,880
Members
419,657
Latest member
ExcelAl1

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
Top