Excel VBA - Loop Transpose

Question

У меня есть определенный диапазон данных. Ниже пример данных:

PAT PID 0  Min  3001 
PAT PID 0  Mean 3754 
PAT PID 0  Max  4542 
CAT PID 1  Min  15004 
CAT PID 1  Mean 15040 
CAT PID 1  Max  15141 
EMM PID 201 Min5 
EMM PID 201 Mean 584120 
EMM PID 201 Max  1339633 

И я хотел бы перенести данные следующим образом:

PAT PID 0  3001 3754 4542 
CAT PID 1  15004 15040 15141 
EMM PID5 584120 1339633 

я нашел подобную ситуацию, выложенные на форуме ранее (как показано ниже)

VBA Code - Copy and Transpose paste with specific conditions

К сожалению, я получаю эту ошибку "error 9: Subscript out the range.". Я проверил имя листа и отладил все, но не повезло.

Edited

В соответствии с просьбой ниже код я попытался б:

Sub test() 
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary") 
Dim CLa As Range, CLb As Range, x&, Names$, ID$, Key 

x = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row 
For Each CLa In Sheets("Sheet3").Range("A1:A" & x) 
If Not Dic.exists(CStr(CLa.Value)) Then 
    ID = CLa.Value 

    For Each CLb In Sheets("Sheet3").Range("A1:A" & x) 
     If CLb.Value = ID Then 

      If Names = "" Then 
       Names = CLb.Offset(, 1).Value 
      Else 
       Names = Names & "," & CLb.Offset(, 1).Value 
      End If 

     End If 
    Next CLb 

Dic.Add ID, Names 
End If 
ID = Empty: Names = Empty 
Next CLa 

x = 1 
For Each Key In Dic 
Sheets("Sheet2").Cells(x, 1).Value = Key 
Sheets("Sheet2").Range(Cells(x, 2), Cells(x, 4)) = Split(Dic(Key), ",") 
x = x + 1 
Next Key 

Sheets("Sheet2").Cells.Replace "#N/A", Replacement:="" 

End Sub 

Answer 1

Попробуйте это:

Sub test() 
     Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary") 
     Dim CLa As Range, CLb As Range, x&, Names$, ID$, Key 
     Dim n As Integer 
     Dim trValue() As String 


     x = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row 
     For Each CLa In Sheets("Sheet3").Range("A1:A" & x) 
      If Not Dic.exists(CStr(CLa.Value)) Then 
       ID = CLa.Value 

       For Each CLb In Sheets("Sheet3").Range("A1:A" & x) 
        If CLb.Value = ID Then 

         If Names = "" Then 
          Names = CLb.Offset(, 3).Value 
         Else 
          Names = Names & "," & CLb.Offset(, 3).Value 
         End If 

        End If 

       Next CLb 

       Dic.Add ID, Names 
      End If 
     ID = Empty: Names = Empty 
     Next CLa 

     x = 1 
     n = 0 
     For Each Key In Dic 
      Sheets("Sheet2").Cells(x, 1).Value = Key 

      trValue = Split(Dic(Key), ",") 
      For n = 0 To UBound(trValue) 
       Sheets("Sheet2").Cells(x, n + 2).Value = Trim(trValue(n)) 
      Next n 



      x = x + 1 
     Next Key 

    Sheets("Sheet2").Cells.Replace "#N/A", Replacement:="" 

End Sub 

Answer 2

Поскольку вы хотите сохранить значения столбцов A: C как уникальный идентификатор, необходимо объединить их вместе как String при сохранении их внутри Dictionary как Key с (добавив , между ними). Позже, извлекая информацию в «Sheet2», мы можем использовать funtion Split, чтобы извлечь строку в 3 элемента в массиве IDVal.

Option Explicit 

Sub TestDict() 

Dim Dic As Object 
Dim CLa As Range, CLb As Range, lRow As Long 
Dim Names As String, ID$, Key As Variant, KeyVal As Variant, IDVal As Variant 

Set Dic = CreateObject("Scripting.Dictionary") 

With Sheets("Sheet3") 
    lRow = .Cells(.Rows.Count, "A").End(xlUp).Row 

    For Each CLa In .Range("A1:A" & lRow).Cells 
     If Not Dic.exists(CStr(CLa.Value & "," & CLa.Offset(0, 1).Value & "," & CLa.Offset(0, 2).Value)) Then ' If Not Dic.exists(CStr(CLa.Value)) Then 
      ID = CLa.Value 

      For Each CLb In .Range("A1:A" & lRow).Cells 

       If CLb.Value = ID Then 
        If Names = "" Then 
         Names = CLb.Offset(, 4).Value 
        Else 
         Names = Names & "," & CLb.Offset(, 4).Value 
        End If 
       End If 
      Next CLb 

      ' "Fix"ing the key to include values from columns A:C >> will split them later 
      ID = CLa.Value & "," & CLa.Offset(0, 1).Value & "," & CLa.Offset(0, 2).Value 

      Dic.Add ID, Names 
     End If 

     ID = Empty: Names = Empty 
    Next CLa 
End With 

lRow = 1 
With Sheets("Sheet2") 
    For Each Key In Dic.Keys 
     ' splitting values from "Merged" string Key to array 
     IDVal = Split(Key, ",") 
     .Range("A" & lRow).Resize(1, UBound(IDVal) + 1).Value = IDVal 

     KeyVal = Split(Dic(Key), ",") 
     .Range("D" & lRow).Resize(1, UBound(KeyVal) + 1).Value = KeyVal 
     lRow = lRow + 1 
    Next Key 

End With 

End Sub