VBA /公式逻辑建议

Question

我有一个VBA /公式逻辑问题，希望引起您的注意。

步骤1

用户从Column C Row 2开始完成数据表，该数据表告诉宏每Column B Row 2重复行多少次。

我有一个公式，然后用列标题填充Column A Row 2：

=IF(COUNTA($B2:$D2)=0,"",INDEX($B$1:$G$1,MATCH(FALSE,INDEX(ISBLANK($B2:$G2),0),0)))

上面的公式只会填充第一列Name，如果我们不复制行的话，这很好。但是，问题是我需要填充已重复的行的列标题，以便它在该行的第一个之后的列中查找。

步骤2

这是成品数据表的外观：

示例

任何建议将不胜感激。

Answer 1

Option Explicit
Const TitleRow As Integer = 1
Const StartGenColumn As Integer = 47  ' AU


Sub GenerateRows()
Dim SrcRow As Integer, DestRow As Integer, SrcCol As Integer
Dim NumCoreColumns As Integer, LastGenColumn As Integer
Dim SrcWS As Worksheet, DestWS As Worksheet
Dim i As Integer


    NumCoreColumns = StartGenColumn - 1
    ' find the last column
    LastGenColumn = ActiveSheet.Cells(TitleRow, ActiveSheet.Columns.Count).End(xlToLeft).Column
    ' check if it has the totals
    If InStr(ActiveSheet.Cells(TitleRow + 1, LastGenColumn).Formula, "SUM") Then
        LastGenColumn = LastGenColumn - 1
    Else
        ' put in a total so that we can tell when we've finished processing
        ActiveSheet.Cells(TitleRow + 1, LastGenColumn + 1).Formula = "=SUM(" & ColLetter(StartGenColumn) & (TitleRow + 1) & _
                    ":" & ColLetter(LastGenColumn) & (TitleRow + 1) & ")"
        ' fill down
        ActiveSheet.Range(Cells(TitleRow + 1, LastGenColumn + 1), Cells(ActiveSheet.Rows.Count, LastGenColumn + 1)).FillDown
    End If
    Set SrcWS = ActiveSheet

    If LastGenColumn > StartGenColumn Then
        ' create the new worksheet
        Worksheets.Add
        Set DestWS = ActiveSheet

        Application.ScreenUpdating = False
        ' populate the titles
        SrcWS.Range(SrcWS.Cells(TitleRow, 1), SrcWS.Cells(TitleRow, NumCoreColumns)).Copy
        ' always at top of new sheet
        DestWS.Range(DestWS.Cells(1, 1), DestWS.Cells(1, NumCoreColumns)).PasteSpecial xlPasteAll
        SrcRow = TitleRow + 1
        DestRow = 2
        ' while we still have something to do
        Do While SrcWS.Cells(SrcRow, LastGenColumn + 1) <> "" And SrcWS.Cells(SrcRow, LastGenColumn + 1) > 0
            ' copy the core data
            SrcWS.Range(SrcWS.Cells(SrcRow, 1), SrcWS.Cells(SrcRow, NumCoreColumns)).Copy
            ' what to we need to generate
            For SrcCol = StartGenColumn To LastGenColumn
                For i = 1 To SrcWS.Cells(SrcRow, SrcCol).Value
                    DestWS.Range(DestWS.Cells(DestRow, 1), DestWS.Cells(DestRow, NumCoreColumns)).PasteSpecial xlPasteAll
                    ' copy in the title and colour
                    DestWS.Cells(DestRow, 1).Value = SrcWS.Cells(TitleRow, SrcCol).Value
                    DestWS.Cells(DestRow, 1).Interior.Color = SrcWS.Cells(TitleRow, SrcCol).Interior.Color
                    DestRow = DestRow + 1
                Next i
            Next SrcCol
            SrcRow = SrcRow + 1
        Loop
        Application.CutCopyMode = False
        DestWS.Cells(1, 1).EntireColumn.AutoFit
        Application.ScreenUpdating = True
    End If
End Sub


Private Function ColLetter(Col As Integer) As String
Dim Arr
Arr = Split(Cells(1, Col).Address(True, False), "$")
ColLetter = Arr(0)
End Function