Loop through worksheets, paste data in another worksheet in columns with matching name

Question

I want to merge tables from multiple Excel sheets with uncommon and common column names.

I can't get the loop to go to sheets in my workbook and paste in the combine worksheet.

For example I have the following tables:

Sheet1:

  name    surname   color
  Eva       x       
  steven    y       black
  Mark      z       white

Sheet2:

  Surname  color      name     code
  L         Green     Pim      030 
  O         yellow    Xander   34 
  S                   Rihanna  567

My third sheet (the combine sheet) has all the possible column names of all sheets so it looks like:

name    surname   color  code

The macro should read Sheet1 and Sheet2 then paste data in the combine sheet under the correct column name.

The combine sheet should looks like this, with the elements of Sheet2 under the elements of Sheet1:

name    surname   color     code
 Eva       x       
 steven    y       black
 Mark      z       white
 Pim       L       Green   030
 Xander    O       yellow  34
 Rihanna   S               567

I couldn't get the loop to read then paste data in the right column.

Sub CopyDataBlocks_test2()
  'VARIABLE NAME                  'DEFINITION
  Dim SourceSheet As Worksheet    'The data to be copied is here
  Dim CombineSheet As Worksheet   'The data will be copied here
  Dim ColHeaders As Range         'Column headers on Combine sheet
  Dim MyDataHeaders As Range      'Column headers on Source sheet
  Dim DataBlock As Range          'A single column of data
  Dim c As Range                  'a single cell
  Dim Rng As Range                
  'The data will be copied here (="Place holder" for the first data cell)
  Dim i As Integer

  'Dim WS_Count As Integer         'for all sheets in active workbook
  'Dim j As Integer                'Worksheets count

  'Change the names to match your sheetnames:
  Set SourceSheet = Sheets(2)
  Set CombineSheet = Sheets("Combine")

  With CombineSheet
      Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End (xlToLeft))
      Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 
  End With

  With SourceSheet
      Set MyDataHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))

      For Each c In MyDataHeaders
          If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) = 0 Then
              MsgBox "Can't find a matching header name for " & c.Value & _
                vbNewLine & "Make sure the column names are the same and try again."
              Exit Sub    
          End If
      Next c

      'A2:A & the last cell with something on it on column A
      Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
      Set Rng = Rng.Resize(DataBlock.Rows.Count, 1)
      For Each c In MyDataHeaders
        i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0)

        'Writes the values
        Rng.Offset(, i - 1).Value = Intersect(DataBlock.EntireRow, c.EntireColumn).Value
      Next c
  End With
End Sub

It looks like you don't need VBA - have you tried with just VLOOKUPs? — CallumDA
no? because thise a example of the really dataset that I have and the amount of colnames are huge, so its better to make a vba code. — Hakan Yılmaz

user3598756 user3598756 · Accepted Answer · 2017-01-03T17:49:36

you just wrap your With SourceSheet - End With block code into a For each sourceSheet in Worksheets - Next loop checking not to process "Combine" sheet itself

it'd be cleaner to move that into a helper Sub like follows:

Option Explicit

Sub CopyDataBlocks_test2()
    'VARIABLE NAME                 'DEFINITION
    Dim sourceSheet As Worksheet    'The data to be copied is here
    Dim ColHeaders As Range         'Column headers on Combine sheet

    With Worksheets("Combine") '<--| data will be copied here
        Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
        For Each sourceSheet In Worksheets '<--| loop through all worksheets
            If sourceSheet.Name <> .Name Then ProcessSheet sourceSheet, ColHeaders, .Cells(.Rows.Count, 1).End(xlUp).Offset(1) '<--| process data if not "Combine" sheet
        Next
    End With
End Sub


Sub ProcessSheet(sht As Worksheet, ColHeaders As Range, rng As Range)
    Dim MyDataHeaders As Range      'Column headers on Source sheet
    Dim c As Range                  'a single cell
    Dim i As Integer
    Dim DataBlock As Range          'A single column of data

    With sht
        Set MyDataHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))

        For Each c In MyDataHeaders
            If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) = 0 Then
                MsgBox "In worksheet " & .Name & " can't find a matching header name for " & c.Value & vbNewLine & "Make sure the column names are the same and try again."
                Exit Sub
            End If
        Next c

        Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'A2:A & the last cell with something on it on column A

        For Each c In MyDataHeaders
            i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0)
            rng.Offset(, i - 1).Resize(DataBlock.Rows.Count, 1).Value = DataBlock.Columns(c.Column).Value   'Writes the values
        Next c
    End With
End Sub

Loop through worksheets, paste data in another worksheet in columns with matching name

1 Answers