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   Min     32105
EMM   PID 201   Mean    584120
EMM   PID 201   Max     1339633

我想将数据转换如下：

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

我之前在论坛中发现了类似的情况（如下所示）

VBA Code - Copy and Transpose paste with specific conditions

不幸的是我收到此错误“错误9：下标超出范围。”。我检查了工作表名称并调试了所有内容，但没有运气。

被修改

以下要求是我尝试使用的代码：

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列的值保留为唯一ID，因此需要＆＃34;合并＆＃34;将它们作为String保存在Dictionary内Key（在它们之间添加,）时，它们一起作为Split。稍后，当将信息提取到＆＃34; Sheet2＆＃34;时，我们可以使用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数组中的3个元素。

hooks

Excel VBA - 循环转置

2 个答案: