VBA Macro To Scan Headers and Paste Them Into Specific Column On Master Template

[mirmir]

Hi all,
first let me apologize, because I'm not sure what to as first. But also to say thank you in advance for any help you can provide.

I have a spreadsheet that other groups have decided to use. However, they don't need all the information from my sheet. I have 100 columns in a specific order that I collect information on. Others take that spreadsheet and delete whatever they don't need. However, now it's necessary for me to merge their information into my format. That said, can someone help me to build a macro that will look at their headers in one sheet a master template and copy the column into the specific column in the master template?

[NoSparks]

try this, it copies data from "Dept A Sheet" to "Master Layout", but not all your headers match.


Sub DataToColumnsByHeader()
Dim src As Worksheet, dest As Worksheet
Dim srcLR As Long, destLR As Long
Dim rng As Range, cel As Range, foundRng As Range

Set src = Sheets("Dept A Sheet")
Set dest = Sheets("Master Layout")

With dest
destLR = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
End With

With src
srcLR = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Set rng = Range(.Cells(1, 1), .Cells(1, Columns.Count).End(xlToLeft))

For Each cel In rng
Set foundRng = dest.Rows(1).Find(What:=cel.Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not foundRng Is Nothing Then
foundRng.Offset(destLR).Resize(srcLR - 1).Value = _
Intersect(.Columns(cel.Column), .UsedRange.Offset(1).Resize(srcLR - 1)).Value
End If
Next cel
End With

End Sub

[Paul_Hossler]

Try this

It could be easily extended to open the data workbook and pull in the data, or do multiple sheets from this workbook





Option Explicit
Sub MergeToMaster()
Dim ws As Worksheet
Dim masterSheet As Worksheet, dataSheet As Worksheet
Dim masterData As Range, dataData As Range
Dim masterRow As Long, masterCol As Long, dataCol As Long, dataRow As Long
Dim dataColNumbers() As Long

'set sheets
Set masterSheet = Worksheets("Master Layout")
Set masterData = masterSheet.Cells(1, 1).CurrentRegion
Set dataSheet = Worksheets("Dept A Sheet")
Set dataData = dataSheet.Cells(1, 1).CurrentRegion

masterRow = masterData.Rows.Count + 1

'build array of destination col numbers, 0 if not on master
ReDim dataColNumbers(1 To dataData.Columns.Count)

'fill the array one time
For dataCol = 1 To dataData.Columns.Count
masterCol = 0
On Error Resume Next
masterCol = Application.WorksheetFunction.Match(dataSheet.Cells(1, dataCol).Value, masterSheet.Rows(1), 0)
On Error GoTo 0

dataColNumbers(dataCol) = masterCol
Next dataCol

'now move data over, data red if not on master, green is it is
For dataRow = 2 To dataData.Rows.Count
For dataCol = 1 To dataData.Columns.Count
If dataColNumbers(dataCol) = 0 Then ' no matching col header
dataSheet.Cells(dataRow, dataCol).Interior.Color = vbRed
Else
masterSheet.Cells(masterRow, dataColNumbers(dataCol)).Value = dataSheet.Cells(dataRow, dataCol).Value
dataSheet.Cells(dataRow, dataCol).Interior.Color = vbGreen
End If
Next dataCol

masterRow = masterRow + 1
Next dataRow
End Sub

[mirmir]

Thank you. It's true the headers may not match. They may change them and delete them. But I can only move information with an exact match.

[mirmir]

Thank you so much. I'm going to try to make a button that I can use to open the workbook and do the copy. I want to try to learn as much as I can.