需要Excel VBA代码粘贴到列A中的下一个空白单元格中

Question

我当前已将代码粘贴到工作表“项目”的下一个空白行中的工作表“项目”的列A中。 我希望它粘贴到工作表“ Assignment”的第一个空白单元格中。

Option Explicit

Sub CopyPasteX()
    'Declare variables
    Dim projName As String
    Dim projCount As Integer, lRow As Integer, lRow2 As Integer, i As Integer, j As Integer

    'Find last row
    lRow = Sheets("Projects").Range("A" & Rows.Count).End(xlUp).Row

    'Begin loop - CHANGE BELOW FROM 2 TO 1 IF SPREADSHEET DOES NOT INCLUDE HEADDERS
    For i = 2 To lRow

        'Set project names and the project count
        projName = Sheets("Projects").Range("A" & i)
        projCount = Sheets("Projects").Range("B" & i)

        'Second loop for pasting in project
        For j = 1 To projCount

            'Find last row on sheet 2
            lRow2 = Sheets("Assignment").Range("A" & Rows.Count).End(xlUp).Row


            'Paste in the project name on sheet2
            Sheets("Assignment").Range("A" & lRow2 + 1).Value = projName

        'Loop to continue copying based on the project count
        Next j

    'Loop to next project
    Next i

End Sub

Answer 1

编辑 ：我修改了lRow2的定义，并重构整个代码以利用With ... End With sintax和参考正确的工作表

Sub CopyPasteX()
    'Declare variables

    Dim lRow2 As Integer, j As Long

    Dim cell As Range
    With Sheets("Projects") 'reference wanted sheet
        'loop through referenced sheet column A cells from row 1 down to last not empty one
        'Begin loop - CHANGE BELOW FROM "A2" TO "A1" IF SPREADSHEET DOES NOT INCLUDE HEADDERS
        For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))

            'Second loop for pasting in project, taking current cell adjacent one as the ending value
            For j = 1 To cell.Offset(, 1)

                'Find firts empty cell on sheet Assignment
                With Sheets("Assignment")
                    Select Case True
                        Case IsEmpty(.Range("A1"))
                            lRow2 = 0
                        Case WorksheetFunction.CountA(.Range("A1", .Cells(.Rows.Count, "A").End(xlUp))) = 1
                            lRow2 = 1
                        Case Else
                            lRow2 = .Range("A1").End(xlDown).row
                    End Select
                    .Range("A" & lRow2 + 1).Value = cell.Value 'Paste current cell value (i.e. project name) in referenced sheet column A at row lRow
                End With

            'Loop to continue copying based on the project count
            Next

        'Loop to next project
        Next
    End With

End Sub

Answer 2

            'Find last row on sheet 2
           lRow2 = Sheets("Assignment").[A1].End(xlDown).Row

我发现这完全符合我的需要。

编辑：这不起作用，如答复中所述。

Answer 3

不需要内循环。 试试这个代码

Sub CopyPasteX()
Dim projName    As String
Dim projCount   As Integer
Dim lRow        As Integer
Dim lRow2       As Integer
Dim i           As Integer

lRow = Sheets("Projects").Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To lRow
    projName = Sheets("Projects").Range("A" & i)
    projCount = Sheets("Projects").Range("B" & i)

    lRow2 = Sheets("Assignment").Range("A" & Rows.Count).End(xlUp).Row
    lRow2 = IIf(lRow2 = 1, 1, lRow2 + 1)

    Sheets("Assignment").Range("A" & lRow2).Resize(projCount).Value = projName
Next i
End Sub

另一个代码（使用数组）

Sub Test()
Dim arr         As Variant
Dim temp()      As String
Dim i           As Long
Dim j           As Long
Dim k           As Long

arr = Sheets("Projects").Range("A2:B" & Sheets("Projects").Cells(Rows.Count, 1).End(xlUp).Row).Value

j = 1: k = 1

For i = 1 To UBound(arr, 1)
    k = k + arr(i, 2)
    ReDim Preserve temp(1 To k)
    For j = j To k
        temp(j) = arr(i, 1)
    Next j
    j = k
Next i

With Sheets("Assignment").Range("A1")
    .Resize(k - 1, 1).Value = Application.Transpose(temp)
End With
End Sub