Создайте две строки для каждого уникального значения в столбце и вычтите

Question

У меня есть список проектов в Excel.У каждого проекта есть три строки (act, plan, fcst) и много столбцов (один столбец = один месяц).

Что я хотел бы сделатьвыглядит следующим образом:

A) для каждого уникального значения в столбце D (проект №) добавить две строки |Завершено

B) план вычитания - актуально в одной из новых строк

C) вычитать fcst - актуально во второй из новых строк

A *) создать две новые строки и скопироватьданные из столбцов A: AE для каждого уникального значения в столбце D (проект №) |Необязательно - я могу обработать вариант A), но A * будет лучше.

Кто-нибудь знает, как написать код для выполнения пунктов B, C, A *?Я понятия не имею, как справиться с этим.

Это конечный вывод, который я хотел бы видеть (желтые и оранжевые строки - это новые, которые я хочу, чтобы макрос создавал для каждого уникального проекта # в столбцеD):

Текст в AF всегда имеет значение «Plan $ 000's», «Actual $ 000's» или «Forecast $ 000's», для каждого проекта (т.е. каждый отдельный проект имеет эти тристрок не меньше, не больше).

Данные сортируются по удару # (столбец D).Это означает, что первые три строки относятся к проекту № 123, следующие три относятся к проекту № 129, следующие три - к проекту № 761 и т. Д.

Нам разрешено играть (сортировать, фильтровать и т. Д.) Сданные до тех пор, пока мы получаем желаемый результат.: -)

Ниже приведен код, который у меня есть сейчас ... он довольно плохой:

Sub CreateAndCompare() 
Dim rng As Range
Dim cl As Range
Dim dic As Object
Dim ky As Variant
Set dic = CreateObject("Scripting.Dictionary")

With Sheets("Impact")
    Set rng = .Range(.Range("D2"), .Range("D" & .Rows.Count).End(xlUp))
End With

For Each cl In rng
    If Not dic.exists(cl.Value) Then
        dic.Add cl.Value, cl.Value
    End If
Next cl

For Each ky In dic.keys
      lastrow = ActiveSheet.Range("d2").CurrentRegion.Rows.Count
      Cells(lastrow + 1, 4).Value = dic(ky)
      Cells(lastrow + 2, 4).Value = dic(ky)


Next ky

End Sub

спасибо!

Answer 1

Я предлагаю следующее:

1. Цикл по всем строкам данных
2. Найти план строк / факт / прогноз для текущего воздействия нет
3. Затем запишитерасчеты до конца рабочего листа

Таким образом, вы получите что-то вроде этого:

Option Explicit

Public Sub CreateAndCompare()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Impact")

    'we assume here that the sheet is already sorted by column D "Impact #"

    Dim LastDataRow As Long 'find last used row
    LastDataRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    Dim LastDataColumn As Long 'find last used column
    LastDataColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    Dim NextEmptyRow As Long
    NextEmptyRow = LastDataRow + 1

    Dim iRow As Long, PlanRow As Long, ActualRow As Long, ForcastRow As Long
    For iRow = 2 To LastDataRow 'loop through all data rows
        Select Case ws.Cells(iRow, "AF").Value 'check which row type the current iRow is and remember
            Case "Plan $000's":     PlanRow = iRow
            Case "Actual $000's":   ActualRow = iRow
            Case "Forecast $000's": ForcastRow = iRow
        End Select

        'detect change of impact no
        If ws.Cells(iRow, "D").Value <> ws.Cells(iRow + 1, "D").Value Or iRow = LastDataRow Then
            'check if plan/actual/forecast rows were found (if one is missing we cannot calculate
            If PlanRow > 0 And ActualRow > 0 And ForcastRow > 0 Then
                'copy column A-AE to next 2 empty rows
                ws.Cells(NextEmptyRow, "A").Resize(RowSize:=2, ColumnSize:=31).Value = ws.Cells(iRow, "A").Resize(ColumnSize:=31).Value

                'write purpose
                ws.Cells(NextEmptyRow, "AF").Value = "Act - Plan"
                ws.Cells(NextEmptyRow + 1, "AF").Value = "Act - Fcst"

                'calculate
                Dim iCol As Long
                For iCol = 33 To LastDataColumn
                    ws.Cells(NextEmptyRow, iCol).Value = ws.Cells(ActualRow, iCol).Value - ws.Cells(PlanRow, iCol).Value
                    ws.Cells(NextEmptyRow + 1, iCol).Value = ws.Cells(ActualRow, iCol).Value - ws.Cells(ForcastRow, iCol).Value
                Next iCol


                NextEmptyRow = NextEmptyRow + 2 'initialize for next impact no
            End If

            PlanRow = 0: ActualRow = 0: ForcastRow = 0 'initialize for next impact no
        End If
    Next iRow
End Sub

Answer 2

Я думаю, что нашел решение.:-)

Я создал дополнительный столбец AG, который объединяет Impact # & Purpose (столбцы D & AF).

Однако выполнение кода занимает ~ 15 минут.

Кто-нибудь может подсказать, что мне следует изменить, чтобы сделать его быстрее?

Sub CreateAndCompare()
Dim rng As Range
Dim cl As Range
Dim dic As Object
Dim ky As Variant

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("Impact")
        Set rng = .Range(.Range("D2"), .Range("D" & .Rows.Count).End(xlUp))
    End With

    For Each cl In rng
        If Not dic.exists(cl.Value) Then
            dic.Add cl.Value, cl.Value
        End If
    Next cl

    For Each ky In dic.keys
          lastrow = ActiveSheet.Range("d2").CurrentRegion.Rows.Count
          Cells(lastrow + 1, 4).Value = dic(ky)
          Cells(lastrow + 1, 32).Value = "Act-Plan"
          Cells(lastrow + 1, 33).Value = "Plan $000's"


          For i = 2 To 43
          mylookupvalue = Cells(lastrow + 1, 4) & "Actual $000's"
          mylookupvalue_2 = Cells(lastrow + 1, 4) & Cells(lastrow + 1, 33)
          myfirstcolumn = 33
          mylastcolumn = 43
          mycolumnIndex = i
          myfirstrow = 2
          mylastrow = lastrow
          mytablearray = Worksheets("Impact").Range(Cells(myfirstrow, myfirstcolumn), Cells(mylastrow, mylastcolumn))

          On Error Resume Next

          value_1 = Application.WorksheetFunction.VLookup(mylookupvalue, mytablearray, mycolumnIndex, False)
          value_2 = Application.WorksheetFunction.VLookup(mylookupvalue_2, mytablearray, mycolumnIndex, False)

          Cells(lastrow + 1, i + 32).Value = value_1 - value_2

          Cells(lastrow + 2, 4).Value = dic(ky)
          Cells(lastrow + 2, 32).Value = "Act-Fcst"
          Cells(lastrow + 2, 33).Value = "Forecast $000's"

          mylookupvalue_3 = Cells(lastrow + 2, 4) & "Actual $000's"
          mylookupvalue_4 = Cells(lastrow + 2, 4) & Cells(lastrow + 2, 33)

          value_3 = Application.WorksheetFunction.VLookup(mylookupvalue_3, mytablearray, mycolumnIndex, False)
          value_4 = Application.WorksheetFunction.VLookup(mylookupvalue_4, mytablearray, mycolumnIndex, False)

          Cells(lastrow + 2, i + 32).Value = value_3 - value_4

          Next i

    Next ky

    Worksheets("Impact").Range("AH2:BW10024").NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"

End Sub