Изменение порядка данных Excel с использованием VBA

Question

Здравствуйте. Я пытаюсь изменить порядок данных в Excel с помощью VBA. Текущие данные

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

End Sub

Вывод не близок к тому, что я хочу:

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

Answer 1

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

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

Answer 2

Вот другой подход, использующий словари вместо этого для получения желаемого результата.

Идея состоит в том, чтобы прочитать строки данных (в виде строк) в словарь, используя ключ, состоящий из 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