VBA: Copy and paste row data in multiple column if Sheet1 ID matches with SheetY ID

[tyavan]

VBA: Copy and paste row data in multiple column if Sheet1 ID matches with SheetY ID
---------------------------------------------------------------------------------------------------------------------------------------
Sheet1 has a list of ID in ColumnA
SheetY has multi column row data with ID in ColumnA.
If any Sheet1.ColumnA ID matches with any SheetY.ColumnA ID then copy entire row in Sheet1.
If more than one row exists then copy paste the SheetY.ColumnA ID row data below the ID row.


ID appear as:
000- 1A'*1
2asdf
jhg3 h

[tyavan]

[austenr]

please post a copy of a sample workbook in order to have people help you

[tyavan]

Please find the attachment.
This is mock data. Original range is big and there are more sheets.
The VBA code will not work in Noeffectsheet, but will show the result as in result sheet.

[tyavan]

[mana]

Option Explicit


Sub test()
    Dim dicY As Object, y As Long
    Dim dicX As Object, x As Long
    Dim dic As Object
    Dim w() As String
    Dim ws As Worksheet
    Dim r As Range
    Dim j As Long, k As Long
    Dim s As String, ss As String
    Dim n As Long
    Dim a
    
    Set dicX = CreateObject("scripting.dictionary")
    Set dicY = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    
    For Each ws In Worksheets
        If ws.Name <> "Result" And ws.Name <> "Noeffectsheet" Then
            Set r = ws.Cells(1).CurrentRegion
                
            For k = 2 To r.Columns.Count
                s = r(1, k).Value
                If Not dicX.exists(s) Then
                    x = dicX.Count + 1
                    dicX(s) = x
                End If
            Next
            
            For j = 2 To r.Rows.Count
                n = WorksheetFunction.CountIf(r(1).Resize(j), r(j, 1))
                ss = r(j, 1).Value & IIf(n > 1, "@@" & WorksheetFunction.CountIf(r(1).Resize(j), r(j, 1)), "")
                If Not dicY.exists(ss) Then
                    y = dicY.Count + 1
                    dicY(ss) = y
                End If
                y = dicY(ss)
                
                For k = 2 To r.Columns.Count
                    s = r(1, k).Value
                    x = dicX(s)
                    dic(y & " " & x) = dic(y & " " & x) & " " & r(j, k).Value
                Next 
            Next 
        End If
    Next 
    
    ReDim w(1 To dicY.Count, 1 To dicX.Count)
    
     For Each a In dic.keys
        w(Split(a)(0), Split(a)(1)) = Join(Split(WorksheetFunction.Trim(dic(a))), ",")
     Next
     
     With Worksheets("Result")
        .UsedRange.ClearContents
        .Cells(1, 2).Resize(, dicX.Count).Value = dicX.keys
        .Cells(2, 1).Resize(dicY.Count).Value = Application.Transpose(dicY.keys)
        .Cells(2, 2).Resize(dicY.Count, dicX.Count).Value = w
        .UsedRange.Sort .Cells(1), Header:=xlYes
        .Columns(1).Replace "*@@*", ""
     End With
     
End Sub

マナ

[tyavan]

Thanks but the VBA code din't gave the expected mock result. Its not able to concatenate data from different sheet in a cell. Also it missed the # column. In original there are more columns and rows.

[mana]

Use original data, not mock data.

[tyavan]

Nope its not working. It can't copy all cell data by "matching ID and column headers" from all sheets in result sheet cells separated by comma.

[mana]

> Set r = ws.Cells(1).CurrentRegion


Set r = ws.usedrange

[mana]

Option Explicit




Sub test2()
    Dim dicY As Object, y As Long
    Dim dicX As Object, x As Long
    Dim dic As Object
    Dim w() As String
    Dim ws As Worksheet
    Dim r As Range
    Dim j As Long, k As Long
    Dim s As String, ss As String
    Dim n As Long
    Dim a
    
    Set dicX = CreateObject("scripting.dictionary")
    Set dicY = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    
    For Each ws In Worksheets
        If ws.Name <> "Result" And ws.Name <> "Noeffectsheet" Then
            Set r = ws.UsedRange
                
            For k = 2 To r.Columns.Count
                s = r(1, k).Value
                If s <> "" Then
                    If Not dicX.exists(s) Then
                        x = dicX.Count + 1
                        dicX(s) = x
                    End If
                End If
            Next
            
            
            For j = 2 To r.Rows.Count
                If r(j, 1).Value <> "" Then
                    n = WorksheetFunction.CountIf(r(1).Resize(j), r(j, 1))
                    ss = r(j, 1).Value & IIf(n > 1, "@@" & WorksheetFunction.CountIf(r(1).Resize(j), r(j, 1)), "")
                    If Not dicY.exists(ss) Then
                        y = dicY.Count + 1
                        dicY(ss) = y
                    End If
                    y = dicY(ss)
                    
                    For k = 2 To r.Columns.Count
                        If r(1, k).Value <> "" Then
                            s = r(1, k).Value
                            x = dicX(s)
                            dic(y & " " & x) = dic(y & " " & x) & " " & r(j, k).Value
                        End If
                    Next
                End If
            Next
        End If
    Next
    
    ReDim w(1 To dicY.Count, 1 To dicX.Count)
    
     For Each a In dic.keys
        w(Split(a)(0), Split(a)(1)) = Join(Split(WorksheetFunction.Trim(dic(a))), ",")
     Next
     
     With Worksheets("Result")
        .UsedRange.ClearContents
        .Cells(1, 2).Resize(, dicX.Count).Value = dicX.keys
        .Cells(2, 1).Resize(dicY.Count).Value = Application.Transpose(dicY.keys)
        .Cells(2, 2).Resize(dicY.Count, dicX.Count).Value = w
        .UsedRange.Sort .Cells(1), Header:=xlYes
        .Columns(1).Replace "*@@*", ""
     End With
     
End Sub