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