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]

:crying:

[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]

:crying::banghead:

[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