使用VBA

Question

您好，我正在尝试使用VBA重新整理excel中的数据。 当前数据是

Project Task    Resource
P1  T1  R1
P1  T1  R2
P1  T3  R3
P1  T3  R4
P1  T3  R5
P2  T6  R6
P2  T7  R7

我希望它看起来像：

Project Task    Resource        
P1  T1  R1  R2  
P1  T3  R3  R4  R5
P2  T6  R6      
P2  T7  R7      

根据项目和任务分配资源。我想先测试项目和任务，所以写了：

Sub Test()
    Dim rw As Long, cl As Long
    Dim Text As String
    Dim Text2 As String

    With ActiveSheet
        For rw = .Cells(Rows.Count, 1).End(xlDown).Row To 6 Step 1
            For cl = .Cells(rw, Columns.Count).End(xlToLeft).Column To 3 Step 1
                If Not IsEmpty(.Cells(rw, cl)) Then
                    Text = Cells(rw, 1).Value
                    Text2 = Cells(rw + 1, 1).Value
                    If Text = Text2 Then
                        .Columns(cl + 1).Insert
                        .Cells(rw, cl + 1) = .Cells(rw, cl + 1).Value2
                        '.Cells(rw + 1, 2) = .Cells(rw, cl).Value2
                        .Cells(rw, cl).Clear
                    End If

                End If
            Next cl
        Next rw
    End With
End Sub

调试后，我意识到光标从

移动

For rw = .Cells(Rows.Count, 1).End(xlDown).Row To 6 Step 1

到

 End With

直接。

我在做什么错，有没有简单的代码可以完成所需的感谢。

我稍微修改了代码： 这是新代码：

Sub Test()
Dim rw As Long, cl As Long
Dim Text As String
Dim Text2 As String
Dim Flag As Integer

With ActiveSheet
    For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        For cl = .Cells(rw, Columns.Count).End(xlToLeft).Column To 2 Step -1
            If Not IsEmpty(.Cells(rw, cl)) Then
                Text = Cells(rw, 1).Value
                Text2 = Cells(rw - 1, 1).Value
                If Text = Text2 Then
                    Flag = Flag + 1
                    '.Columns(cl + 1).Insert
                    .Cells(rw, cl + Flag) = .Cells(rw, cl).Value2
                    '.Cells(rw, cl).Clear

                End If

            End If
        Next cl
    Next rw
End With

结束子

输出远不及我想要的：

Project Task                    
P1  T1                  
P1  T1                  T1
P1  T3              T3  
P1  T3          T3      
P1  T3      T3          
P2  T6                  
P2  T7  T7              

Answer 1

这是使用字典来产生所需结果的另一种方法。

想法是使用由Project和Task组成的键将数据行（作为字符串）读取到字典中。如果字典中还没有行的键，则会添加它。如果已经存在，请附加其他资源。这样，七行数据将产生一个字典，其中包含代表所需输出的四个字符串项。最后一步是将字典的内容读取到工作表中。

假定数据位于范围A1：C7中，下面的代码将在以下屏幕截图中生成结果，所需的输出范围为E1：I4。

请注意，这要求您设置对Microsoft Scripting Runtime的引用，如下面的代码所示。

MultipartFileData

Answer 2

尝试一下。

Sub test()
    Dim d As Object, vS As Variant
    Dim vDB, a, vR()
    Dim s As String
    Dim i As Long, n As Long
    Dim j As Integer, c As Integer


    vDB = Range("a1", Range("c" & Rows.Count).End(xlUp))
    n = UBound(vDB, 1)

    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To n
        s = vDB(i, 1) & "," & vDB(i, 2)
        If d.Exists(s) Then
        Else
            d.Add s, i
        End If
    Next i
    a = d.keys
    ReDim vR(1 To d.Count, 1 To 10)
    For i = 0 To d.Count - 1
        c = 2
        For j = 1 To n
            s = vDB(j, 1) & "," & vDB(j, 2)
            If s = a(i) Then
                vR(i + 1, 1) = vDB(j, 1)
                vR(i + 1, 2) = vDB(j, 2)
                c = c + 1
                vR(i + 1, c) = vDB(j, 3)
            End If
        Next j
    Next i
    Sheets.Add
    Range("a1").Resize(UBound(vR, 1), UBound(vR, 2)) = vR

End Sub