Как создать новую строку после выполнения условия? Excel / VBA

Question

У меня есть таблица данных, которая содержит 1300 строк данных и следующую информацию в виде столбцов:

Week Number/Name/Function/Department/Project 1/Project 2/Project 3/Project 4.

В столбцах проекта я указываю в каждой ячейке, сколько часов человек работал в определенном проекте в течение конкретной недели.

Пример:

Week 2/Name of Person/Engineer/Engineering/4h/3h/8h/0h.

Я хотел преобразовать эти данные в следующий формат, создавая по одной строке для каждого проекта.

Пример:

Week 2/Name of Person/Engineer/Engineering/Project 1/4h.

Week 2/Name of Person/Engineer/Engineering/Project 2/3h.

Week 2/Name of Person/Engineer/Engineering/Project 3/8h.

Week 2/Name of Person/Engineer/Engineering/Project 4/0h.

Это как-то возможно?

Спасибо.

Answer 1

Четыре в один столбец

Код

Sub FourToOneColumn()

   ' Source2 List of Headers
   Const cStrH As String = "Project 1,Project 2,Project 3,Project 4"
   ' Source
   Const cSheet1 As Variant = "Sheet1"  ' Source Worksheet Name/Index
   Const cCol1 As Variant = "A"         ' Source1 First Column Letter/Number
   Const cCol2 As Variant = "D"         ' Source1 Last Column Letter/Number
   Const cCol3 As Integer = 4           ' Source2 Number of Split Columns
   Const cEmpty As Boolean = False      ' Enable Include Empty Cells
   Const cTitle As String = "Hours"     ' Title of New Column
   Const cNew As Integer = 1            ' Number of New Columns
   Const cRow1 As Integer = 2           ' Source First Data Row
   Const lRowCol As Variant = "A"       ' Source Last Row Column Letter/Number
   ' Target
   Const cSheet2 As Variant = "Sheet1"  ' Target Worksheet Name/Index
   Const cCell As String = "J1"         ' Target First Cell Address

   Dim vnt1 As Variant  ' Source1 Array
   Dim vnt2 As Variant  ' Source2 Array
   Dim vntH As Variant  ' Header Array
   Dim vnt3 As Variant  ' Source1 Header Array
   Dim vntT As Variant  ' Target Array

   Dim lRow As Long     ' Last Row
   Dim i As Long        ' Source Arrays Row Counter
   Dim j As Integer     ' Source2 Array Column Counter
   Dim k As Long        ' Target Array Row Counter
   Dim m As Integer     ' Source1 Array Column Counter

   ' Write List of Headers into Header Array.
   vntH = Split(cStrH, ",")

   ' Paste Source Ranges into Source Arrays.
   With Worksheets(cSheet1)
       lRow = .Cells(.Rows.Count, lRowCol).End(xlUp).Row
       vnt1 = .Range(.Cells(cRow1, cCol1), .Cells(lRow, cCol2))
       vnt2 = .Range(.Cells(cRow1, cCol2).Offset(0, 1), _
               .Cells(lRow, cCol2).Offset(0, 1 + cCol3 - 1))
       vnt3 = .Range(.Cells(cRow1 - 1, cCol1), .Cells(cRow1 - 1, cCol2))

   End With

   ' Count number of rows in Target Array.
   If Not cEmpty Then
       ' If "" will not be included:
       For i = 1 To UBound(vnt2)
           For j = 1 To UBound(vnt2, 2)
               If vnt2(i, j) <> "" Then
                   k = k + 1
               End If
           Next
       Next
       k = k + 1 ' 1 row for headers.
     Else
       ' If "" will be included:
       k = UBound(vnt2) * UBound(vnt2, 2) + 1 ' 1 row for headers.
   End If

   ' Resize Target Array.
   ReDim vntT(1 To k, 1 To UBound(vnt1, 2) + cNew)

   ' Write headers to Target Array
   k = 1
   For j = 1 To UBound(vnt3, 2)
       vntT(k, j) = vnt3(1, j)
   Next
   vntT(k, j) = cTitle

   ' Write data to Target Array.
    For i = 1 To UBound(vnt2)
        For j = 1 To UBound(vnt2, 2)
            ' If "" will not be included:
            If Not cEmpty Then
                If vnt2(i, j) <> "" Then
                    GoSub WriteTarget
                End If
              Else ' If "" will not be included:
                GoSub WriteTarget
            End If
        Next
    Next

    ' Paste Target Array into Target Range resized
    ' from Target First Cell Address.
    With Worksheets(cSheet2).Range(cCell)
        .Resize(UBound(vntT), UBound(vntT, 2)) = vntT
    End With

    Exit Sub

WriteTarget:
    k = k + 1
    For m = 1 To UBound(vnt1, 2)
        vntT(k, m) = vnt1(i, m)
    Next
    vntT(k, m) = vnt2(i, j)
    Return

End Sub