Combine Multiple Sheets into One Based on ID and Column Names

[ismphoto123]

Hello,

I have been stuck on this project for weeks. There are six sheets. One named 'Macro' that will have instructions and command buttons, 'Results' where the data would populate, and APAR, MBS, Purchase, and Sales. So the common identifier is the CUSIP. Not all sheets will have the same cusips, but the first two columns 'CUSIP' and 'Asset Description' are the same and the third column contains the value. What I am intending to do is populate the results tab with all CUSIPs and Asset Description's without duplicates. Then I would like the macro to look through CUSIPS in the last four sheets and return the value from the third column of that sheet into the corresponding column in the Results tab.

Below is an example of the Results tab and an APAR (which has the same layout, and just a different column header which is the same column header as Results tab). Thank you in advance for your help! I also have to add more sheets and more columns to the Results sheet, this is just a simplified version.

[TABLE="width: 471"]
<colgroup><col><col><col span="4"></colgroup><tbody>[TR]
[TD]CUSIP[/TD]
[TD]Asset Description [/TD]
[TD] APAR[/TD]
[TD] MBS[/TD]
[TD] Purchase[/TD]
[TD] Sales[/TD]
[/TR]
[TR]
[TD="align: right"]111111111 [/TD]
[TD]this1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]18[/TD]
[TD="align: right"]26[/TD]
[/TR]
[TR]
[TD="align: right"]222222222 [/TD]
[TD]this2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]11[/TD]
[TD="align: right"]19[/TD]
[TD="align: right"]27[/TD]
[/TR]
[TR]
[TD="align: right"]333333333 [/TD]
[TD]this3[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]12[/TD]
[TD][/TD]
[TD="align: right"]28[/TD]
[/TR]
[TR]
[TD="align: right"]444444444 [/TD]
[TD]this4[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]13[/TD]
[TD="align: right"]20[/TD]
[TD="align: right"]29[/TD]
[/TR]
[TR]
[TD="align: right"]555555555 [/TD]
[TD]this5[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]14[/TD]
[TD="align: right"]21[/TD]
[TD="align: right"]30[/TD]
[/TR]
[TR]
[TD="align: right"]666666666 [/TD]
[TD]this6[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]15[/TD]
[TD="align: right"]22[/TD]
[TD="align: right"]31[/TD]
[/TR]
[TR]
[TD="align: right"]777777777 [/TD]
[TD]this7[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]16[/TD]
[TD="align: right"]23[/TD]
[TD="align: right"]32[/TD]
[/TR]
[TR]
[TD="align: right"]888888888 [/TD]
[TD]this8[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]17[/TD]
[TD="align: right"]24[/TD]
[TD="align: right"]33[/TD]
[/TR]
[TR]
[TD="align: right"]999999999 [/TD]
[TD]this9[/TD]
[TD="align: right"]9[/TD]
[TD][/TD]
[TD="align: right"]25[/TD]
[TD="align: right"]34[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 314"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]CUSIP[/TD]
[TD]Asset Description[/TD]
[TD]APAR[/TD]
[/TR]
[TR]
[TD="align: right"]111111111 [/TD]
[TD]this1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]222222222 [/TD]
[TD]this2[/TD]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD="align: right"]333333333 [/TD]
[TD]this3[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD="align: right"]444444444 [/TD]
[TD]this4[/TD]
[TD="align: right"]4[/TD]
[/TR]
[TR]
[TD="align: right"]555555555 [/TD]
[TD]this5[/TD]
[TD="align: right"]5[/TD]
[/TR]
[TR]
[TD="align: right"]666666666 [/TD]
[TD]this6[/TD]
[TD="align: right"]6[/TD]
[/TR]
[TR]
[TD="align: right"]777777777 [/TD]
[TD]this7[/TD]
[TD="align: right"]7[/TD]
[/TR]
[TR]
[TD="align: right"]888888888 [/TD]
[TD]this8[/TD]
[TD="align: right"]8[/TD]
[/TR]
[TR]
[TD="align: right"]999999999 [/TD]
[TD]this9[/TD]
[TD="align: right"]9[/TD]
[/TR]
</tbody>[/TABLE]

 

[Eric W]

Here is a macro that should do what you'd like:

1) Open your workbook
2) Press Alt-F11 to open the VBA editor
3) From the menu, select Insert --> module
4) Paste this code:

Sub CombineCUSIP()
Dim ResultWS As Worksheet, CUSIP As Object
Dim MySheets As Variant, ws As Variant, MyKeys As Variant, MyItems As Variant
Dim ctr As Long, r As Long, c As Long, i As Long, MyLoc As Integer
Dim MyDesc As String, MyItem As String


' Make a place to save all the items
    Set CUSIP = CreateObject("Scripting.Dictionary")
    
' Set up Result sheet, and select the name of the sheets to read
    Set ResultWS = Sheets("Results")
    MySheets = Array("APAR", "MBS", "Purchase", "Sales")
    
    ResultWS.Cells.ClearContents
    ResultWS.Cells(1, 1) = "CUSIP"
    ResultWS.Cells(1, 2) = "Asset Description"
        
' Read through each sheet
    ctr = 1
    For Each ws In MySheets
        ResultWS.Cells(1, ctr + 2) = ws
' Check each line in the sheet
        r = 2
        While Sheets(ws).Cells(r, 1) <> ""
            MyItem = Sheets(ws).Cells(r, 1)
            If Not CUSIP.exists(MyItem) Then        ' Have we found this item yet?
                MyDesc = Sheets(ws).Cells(r, 2)     ' No, add it
                CUSIP.Add MyItem, MyDesc & String(UBound(MySheets) + 2, Chr(255))
            End If
            MyDesc = CUSIP.Item(MyItem)             ' Get the results so far
            MyLoc = 0
            For i = 1 To ctr + 1
                MyLoc = InStr(MyLoc + 1, MyDesc, Chr(255))
            Next i
' Add the next count
            MyDesc = Left(MyDesc, MyLoc - 1) & Sheets(ws).Cells(r, 3) & Mid(MyDesc, MyLoc)
            CUSIP.Item(MyItem) = MyDesc             ' Save it
            r = r + 1
        Wend
        ctr = ctr + 1
    Next ws
    
' We now have all the items, so save them to the result sheet
    MyKeys = CUSIP.keys
    MyItems = CUSIP.items
    
    For r = 0 To UBound(MyKeys)
        ResultWS.Cells(r + 2, 1) = MyKeys(r)
        c = 2
        While Len(MyItems(r)) > 0
            MyLoc = InStr(MyItems(r), Chr(255))
            MyItem = Left(MyItems(r), MyLoc - 1)
            ResultWS.Cells(r + 2, c) = MyItem
            MyItems(r) = Mid(MyItems(r), MyLoc + 1)
            c = c + 1
        Wend
    Next r
            
' Sort the results
    With ResultWS.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A" & CUSIP.Count + 1)
        .SetRange Range("A1:" & Chr(67 + UBound(MySheets)) & CUSIP.Count + 1)
        .Header = xlYes
        .Apply
    End With
    
End Sub

5) Customize it to your workbook. In particular, change the sheet names in red. If you add more sheets, just add their names to this list.
6) Either run it by pressing F5, or return to Excel, Press Alt-F8, select CombineCUSIP and click Run.

Let me know how that works.

 

[ismphoto123]

Thank you so much! I have been getting a "Subscript out of range" error on every code i've tried for this purpose and I got another one as I was testing this. Is there something I am doing wrong in VBA? I am using a button (form control), should I be using a command button?

This is the line it highlighted: While Sheets(ws).Cells(r, 1) <> ""

 

[Eric W]

The only reason you'd get a "Subscript out of range" error on that line is if one of the sheets you defined on the "MySheets = " line does not exist. Check that the spelling is exactly the same, and that there are no extra spaces.

 

[Trebor76]

I have been getting a "Subscript out of range" error on every code i've tried for this purpose and I got another one as I was testing this. Is there something I am doing wrong in VBA?

No, that error is when a sheet tab is being referenced by name that doesn't exist. Ensure the five tabs Eric W has highlighted in red are in the workbook exactly as they are written - there could even be a space at the front or end of one of the tabs that makes the tab name 'look' the same as it is in the macro when in fact they're not.

Robert

 

[Rvdrdx]

Sub CallCopyDataAndFormatHeaders()
    Dim sourceSheetName As String
    Dim targetSheetName As String
    
    ' Modify the sheet names as needed
    sourceSheetName = "issues"
    targetSheetName = "combined"
    
    ' Call the subroutine to copy and format data
    CopyDataAndFormatHeaders sourceSheetName, targetSheetName
    
    ' Call the CopyMatchingData subroutine with the desired parameters
    CopyAndColorHeaders "Action Plan", "combined", "green"
    
End Sub

Sub CopyDataAndFormatHeaders(sourceSheetName As String, targetSheetName As String)
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastColumn As Long
    
    ' Set references to the source and target sheets
    Set sourceSheet = ThisWorkbook.Sheets(sourceSheetName)
    Set targetSheet = ThisWorkbook.Sheets(targetSheetName)
    
    ' Clear existing data in the target sheet
    targetSheet.Cells.Clear
    
    ' Copy data from the source sheet to the target sheet
    sourceSheet.Cells.Copy targetSheet.Range("A1")
    
    ' Copy header row from source to target
    sourceSheet.Rows(1).Copy targetSheet.Rows(1)
    
    ' Copy header row from source to target
    sourceSheet.Rows(2).Copy targetSheet.Rows(2)
    
    ' Set the background color of header cells in target sheet
    Dim lastCol As Long
    lastCol = targetSheet.Cells(1, targetSheet.Columns.Count).End(xlToLeft).Column
    targetSheet.Range(targetSheet.Cells(1, 1), targetSheet.Cells(2, lastCol)).Interior.color = RGB(200, 200, 200) ' Gray color for header cells
    
    ' Autofit columns in the target sheet
    targetSheet.Cells.EntireColumn.AutoFit
    
    ' Clean up
    Set sourceSheet = Nothing
    Set targetSheet = Nothing
End Sub

Sub CopyAndColorHeaders(sourceSheetName As String, targetSheetName As String, Optional color As String = "blue")
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim sourceHeaderRange As Range
    Dim targetHeaderRange As Range
    Dim lastColumn As Long

    ' Set references to the source and target sheets
    On Error Resume Next
    Set sourceSheet = ThisWorkbook.Sheets(sourceSheetName)
    Set targetSheet = ThisWorkbook.Sheets(targetSheetName)
    On Error GoTo 0

    If sourceSheet Is Nothing Then
        MsgBox "Source sheet '" & sourceSheetName & "' not found!", vbExclamation
        Exit Sub
    End If

    If targetSheet Is Nothing Then
        MsgBox "Target sheet '" & targetSheetName & "' not found!", vbExclamation
        Exit Sub
    End If

    ' Find the last column in the target sheet
    lastColumnSource = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column

    ' Find the last column in the target sheet
    lastColumn = targetSheet.Cells(1, targetSheet.Columns.Count).End(xlToLeft).Column

    ' Copy the headers from source sheet row 1 and row 2
    Set sourceHeaderRange = sourceSheet.Range(sourceSheet.Cells(1, 1), sourceSheet.Cells(2, lastColumnSource))
    Set targetHeaderRange = targetSheet.Range(targetSheet.Cells(1, lastColumn + 1), targetSheet.Cells(2, lastColumn + 1 + sourceHeaderRange.Columns.Count - 1))

    sourceHeaderRange.Copy targetHeaderRange

    ' Apply the specified color to the newly pasted header rows
    Select Case LCase(color)
        Case "blue"
            targetHeaderRange.Interior.color = RGB(173, 216, 230) ' Light Blue
        Case "green"
            targetHeaderRange.Interior.color = RGB(144, 238, 144) ' Light Green
        Case "orange"
            targetHeaderRange.Interior.color = RGB(255, 204, 153) ' Light Orange
        Case Else
            MsgBox "Invalid color specified. Defaulting to light blue.", vbExclamation
            targetHeaderRange.Interior.color = RGB(173, 216, 230) ' Light Blue
    End Select
End Sub


Sub TestCopyData()
    CopyDataToTargetSheet "Action Plan", "combined", "Parent Objects", "Unique ID"
End Sub



Sub CopyDataToTargetSheet(ByVal sourceSheetName As String, ByVal targetSheetName As String, ByVal sourceColumnName As String, ByVal targetColumnName As String)
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim sourceLastRow As Long
    Dim targetLastRow As Long
    Dim sourceColumnIndex As Long
    Dim targetColumnIndex As Long
    Dim sourceCell As Range
    Dim targetCell As Range
    Dim sourceDataRange As Range
    Dim targetDataRange As Range
    
    ' Get references to source and target sheets
    On Error Resume Next
    Set sourceSheet = ThisWorkbook.Sheets(sourceSheetName)
    Set targetSheet = ThisWorkbook.Sheets(targetSheetName)
    On Error GoTo 0
    
    If sourceSheet Is Nothing Then
        MsgBox "Source sheet '" & sourceSheetName & "' not found.", vbExclamation
        Exit Sub
    End If
    
    If targetSheet Is Nothing Then
        MsgBox "Target sheet '" & targetSheetName & "' not found.", vbExclamation
        Exit Sub
    End If
    
    ' Find the positions of source and target columns
    On Error Resume Next
    sourceColumnIndex = Application.WorksheetFunction.Match(sourceColumnName, sourceSheet.Rows(1), 0)
    targetColumnIndex = Application.WorksheetFunction.Match(targetColumnName, targetSheet.Rows(1), 0)
    On Error GoTo 0
    
    If sourceColumnIndex = 0 Then
        MsgBox "Source column '" & sourceColumnName & "' not found in '" & sourceSheetName & "'.", vbExclamation
        Exit Sub
    End If
    
    If targetColumnIndex = 0 Then
        MsgBox "Target column '" & targetColumnName & "' not found in '" & targetSheetName & "'.", vbExclamation
        Exit Sub
    End If
    
    ' Determine the last row of data in the source and target sheets
    sourceLastRow = sourceSheet.Cells(sourceSheet.Rows.Count, sourceColumnIndex).End(xlUp).Row
    targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, targetColumnIndex).End(xlUp).Row
    
    ' Set the data ranges
    Set sourceDataRange = sourceSheet.Range(sourceSheet.Cells(2, sourceColumnIndex), sourceSheet.Cells(sourceLastRow, sourceColumnIndex).EntireRow)
    Set targetDataRange = targetSheet.Range(targetSheet.Cells(2, targetColumnIndex), targetSheet.Cells(targetLastRow, targetColumnIndex).EntireRow)
    
    ' Loop through the source data and copy it to the target sheet
    For Each sourceCell In sourceDataRange.Columns(sourceColumnIndex).Cells
        Dim matchValue As Variant
        matchValue = sourceCell.Value
        
        ' Find the matching cell in the target sheet
        On Error Resume Next
        Set targetCell = targetDataRange.Columns(targetColumnIndex).Find(What:=matchValue, LookIn:=xlValues, LookAt:=xlWhole)
        On Error GoTo 0
        
        ' If a match is found, copy the entire row from the source sheet to the target sheet
        If Not targetCell Is Nothing Then
            Dim targetRow As Long
            targetRow = targetCell.Row
            sourceCell.EntireRow.Copy
            targetSheet.Cells(targetRow, targetColumnIndex).End(xlToRight).Offset(0, 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End If
    Next sourceCell
End Sub