excel - 使用 VBA 重新排列 Excel 数据

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 的引用，如下面的代码所示。

Sub TestWithDict()
' Requires that the VBA project has a reference to Microsoft Scripting Runtime;
' choose Tools > References > Microsoft Scripting Runtime
    Dim myDict As Scripting.Dictionary
    Dim rngData, rngTarget As Range
    Dim sRowString, sRowKey As String
    Dim sArray() As String
    Dim i, j As Integer

    Set myDict = New Scripting.Dictionary
    Set rngData = ActiveSheet.UsedRange

    ' Loop through the rows:
    For Each rRow In rngData.Rows
        ' Build a string from the row:
        sRowString = rRow.Cells(, 1).Value & ";" & rRow.Cells(, 2).Value & _
            ";" & rRow.Cells(, 3).Value
        ' Use Project and Task to create a key for the dictionary:
        sRowKey = rRow.Cells(, 1).Value & ";" & rRow.Cells(, 2).Value
        ' Save the string to the Dictionary:
        ' 1) If it doesn't already exist, add it:
        If Not myDict.Exists(sRowKey) Then
            myDict.Add sRowKey, sRowString
        ' 2) If it already exists, append the resource from the third column:
        Else
            myDict.Item(sRowKey) = myDict.Item(sRowKey) & ";" & rrow.Cells(, 3).Value
        End If
    Next rrow
    ' After completing the For block, the dictionary contains 
    ' four strings representing each row in the desired output.

    ' Write the strings in the dictionary to the worksheet:
    Set rngTarget = ActiveSheet.Range("E1")
    i = 0
    For Each sItem In myDict.Items
        sArray = Split(sItem, ";")
        Debug.Print sArray(0), sArray(1), sArray(2)
        For j = 0 To UBound(sArray)
            rngTarget.Offset(i, j) = sArray(j)
        Next j
        i = i + 1
    Next sItem
End Sub