时间戳

首页 > 解决方案 > 满足条件后如何创建新行？Excel/VBA

excel - 满足条件后如何创建新行？Excel/VBA

问题描述

我有一个数据表，其中包含 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.

这有可能吗？

谢谢你。

标签： exceldatabasevba

解决方案

四对一列

编码

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

推荐阅读