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

Question

The code that I have currently pastes the data in Column A of worksheet "Projects" into the next blank row on worksheet "Assignment". I would like it to paste into the first blank cell on worksheet "Assignment" instead.

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

Edit : I amended the lRow2 definition and refactored the whole code to take advantage of With ... End With sintax and reference proper sheet

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

I found that this works exactly how I need it to.

Edit: This does not work as noted in the reply.

Answer 3

No need for inner loop. Try this code

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

Another code (using arrays)

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