Excel VBA - 循环移调 [英] Excel VBA - Loop Transpose

问题描述

我有一定范围的数据。以下是示例数据：

  PAT PID 0最小3001 
 PAT PID 0平均值3754 
 PAT PID 0最大4542 
 CAT PID 1 Min 15004 
 CAT PID 1平均值15040 
 CAT PID 1最大值15141 
 EMM PID 201最小值32105 
 EMM PID 201平均值584120 
 EMM PID 201最大1339633 
  

我想转置如下的数据：

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

我以前发现了类似的情况（如下）

VBA代码 - 复制和转移粘贴特定条件

不幸的是我得到这个错误错误9：下标超出范围。
我已经检查了工作表名称并调试了一切，但没有运气。

已编辑

如下所述，我试图使用的代码：

  Sub test（）
 Dim Dic作为对象：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 
对于每个CLa In Sheets（Sheet3）。Range（A1：A& x）
如果不是Dic.exists（CStr（CLa.Value））然后
 ID = CLa.Value 
 
对于每个CLb在表格（Sheet3）。范围（A1：A& ; x）
如果CLb.Value = ID然后
 
如果Names =然后
名称= CLb.Offset（，1）.Value 
 Else 
 Names = Names& ，& CLb.Offset（，1）.Value 
 End If 
 
 End If 
 Next CLb 
 
 Dic.Add ID，Names 
 End如果
 ID =空：Names = Empty 
下一个CLa 
 
x = 1 
每个键在Dic 
表（Sheet2）。 x，1）.Value = Key 
 Sheets（Sheet2）。Range（Cells（x，2），Cells（x，4））= Split（Dic（Key），，）
x = x + 1 
下一个键
 
表格（Sheet2）。Cells.Replace＃N / A，Replacement：=
 
 End Sub 
  

解决方案

尝试这个：

  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 
对于每个CLa In Sheets（Sheet3）。Range（A1：A& x）
 If不是Dic.exists（CStr（CLa.Value））然后
 ID = CLa.Value 
 
对于每个CLb In Sheets（Sheet3）。Range（A1：A& x）
如果CLb.Value = ID然后
 
如果Names =然后
名称= CLb.Offset（，3）.Value 
 Else 
名称=名称和，& CLb.Offset（，3）.Value 
 End If 
 
 End If 
 
下一个CLb 
 
 Dic.Add ID，Names 
结束如果
 ID =空：Names = Empty 
下一个CLa 
 
x = 1 
n = 0 
每个键在Dic 
表格（Sheet2）。单元格（x，1）.Value = Key 
 
 trValue = Split（Dic（Key），，）
对于n = 0到UBound trValue）
表单（Sheet2）。单元格（x，n + 2）.Value = Trim（trValue（n））
下一个n 
 
 
 
x = x + 1 
下一个键
 
表单（Sheet2）。Cells.Replace＃N / A，Replacement：=
 
 End Sub 
  

I have a certain range of data. Below are the example data:

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

And I would like to transpose the data as follow:

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

I found a similar situation posted in the forum previously(as below)

VBA Code - Copy and Transpose paste with specific conditions

Unfortunately i get this error "error 9: Subscript out of range.". I have checked the sheet name and debugged everything but no luck.

Edited

As requested below are the code i tried to used:

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

解决方案

Try this:

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

这篇关于Excel VBA - 循环移调的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！