CODEWITHSUNDEEP
excelvba
Tom Ruiz
Tom Ruiz

Reputation: 307

How do I copy info based on headers across Excel worksheets?

I was reviewing the following code:

Sub Combine()

  Dim J As Integer
  On Error Resume Next

  Sheets(1).Select

  Worksheets.Add
  Sheets(1).Name = "Combined"
  Sheets(2).Activate
  Range("A1").EntireRow.Select
  Selection.Copy Destination:=Sheets(1).Range("A1")

  For J = 2 To Sheets.Count
     Sheets(J).Activate
     Range("A1").Select
     Selection.CurrentRegion.Select
     Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
     Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
  Next

End Sub

This code combines cells for reporting. This is supposed to copy the info from all the sheets to one combined sheet. However, if I have different headers i.e if in Sheet1!A1 is "Address" and in Sheet2!A1 is "Name", it will copy the names under the address.

Is there a way to have some sort of search so that it will only copy the exact headers and paste them under the correct one?

Upvotes: 1

Views: 1732

Answers (1)

Jerry Sullivan
Jerry Sullivan

Reputation: 126

Here's an example...

Option Explicit

Sub CombineData()
'--combines data from all sheets
'  assumes all sheets have exact same header fields as the
'    first sheet; however the fields may be different order.
'--combines using copy-paste. could be modified to pasteValues only

 Dim lNdxSheet As Long, lNextRow As Long, lDestCol As Long
 Dim lColCount As Long, lRowCount As Long
 Dim rHeaders As Range
 Dim sHeader As String
 Dim vMatch As Variant, vHeaders As Variant
 Dim wksCombined As Worksheet

 With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
 End With

 '--add new sheet for results
 Set wksCombined = Worksheets.Add(Before:=Worksheets(1))

 '--optional: delete existing sheet "Combined"
 On Error Resume Next
 Sheets("Combined").Delete
 On Error GoTo 0

 With wksCombined
   .Name = "Combined"
   '--copy headers that will be used in destination sheet
   Set rHeaders = Sheets(2).Range("A1").CurrentRegion.Resize(1)
   rHeaders.Copy Destination:=.Range("A1")
 End With
 '--read headers into array
 vHeaders = rHeaders.Value
 lColCount = UBound(vHeaders, 2)
 lNextRow = 2

 For lNdxSheet = 2 To Sheets.Count
   '--count databody rows of continguous dataset at A1
   lRowCount = Sheets(lNdxSheet).Range("A1").CurrentRegion.Rows.Count - 1
   If lRowCount > 0 Then
      For lDestCol = 1 To lColCount
         sHeader = vHeaders(1, lDestCol)
         '--search entire first col in case field is rSourceData
         vMatch = Application.Match(sHeader, Sheets(lNdxSheet).Range("1:1"), 0)

         If IsError(vMatch) Then
            MsgBox "Header: """ & sHeader & """ not found on sheet: """ _
               & Sheets(lNdxSheet).Name
            GoTo ExitProc
         End If
         With Sheets(lNdxSheet)
         '--copy-paste this field under matching field in combined
           .Cells(2, CLng(vMatch)).Resize(lRowCount).Copy
           '  Option 1: paste values only
           wksCombined.Cells(lNextRow, lDestCol).PasteSpecial (xlPasteValues)

           '  Option 2: paste all including formats and formulas
           '  wksCombined.Cells(lNextRow, lDestCol).PasteSpecial (xlPasteAll)  
        End With
      Next lDestCol
      lNextRow = lNextRow + lRowCount
   End If ' lRowCount > 0

 Next lNdxSheet
ExitProc:
 With Application
   .ScreenUpdating = True
   .DisplayAlerts = True
 End With

End Sub

Upvotes: 1

Related Questions