Copy Multiple Columns from Multiple Sheets to Master Sheet

[thedeadzeds]

Hi Guys.

I have several sheets in a workbook. All worksheets contain the below columns but not necessarily in the same order and some have additional columns. Is there a way to copy the 6 columns below from all worksheets except the worksheets called "Lookup" and "Data" to the "Master" sheet and only include the columns headers in the top row of the Master Sheet.

Columns to be copied

1. Location
2. Name
3. Post
4. Volume
5. Stock No
6. Total

Thanks

 

[DanteAmor]

Hi @thedeadzeds.

Thanks for posting on the forum.​

The following macro assumes that the headers on all sheets, including the master sheet, are in row 1.
And that the header text in the master sheet matches the text in the sheets, that is, for example, this header "Stock No" in the master sheet, is written in the same way, somewhere in row 1 in the sheets.

Copy all the code including the lines that go at the beginning.

Option Explicit             '<---- At the start of all code
Option Compare Text

Sub CopyColumns()
  Dim shM As Worksheet, shS As Worksheet
  Dim dic As Object
  Dim i As Long, j As Long, lrM As Long, lrS As Long, col As Long
 
  Set shM = Sheets("Master")
  Set dic = CreateObject("Scripting.Dictionary")
 
  For j = 1 To shM.Cells(1, Columns.Count).End(1).Column
    dic(shM.Cells(1, j).Value) = j
  Next
 
  For Each shS In Sheets
    Select Case shS.Name
      Case "Master", "Lookup", "Data"       'Fit the name of the excluded sheets
 
      Case Else
        lrM = shM.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
        lrS = shS.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
       
        For j = 1 To shS.Cells(1, Columns.Count).End(1).Column
          If dic.exists(shS.Cells(1, j).Value) Then
            col = dic(shS.Cells(1, j).Value)
            shM.Cells(lrM, col).Resize(lrS - 1).Value = shS.Cells(2, j).Resize(lrS).Value
          End If
        Next
    End Select
  Next
End Sub

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