Question

我目前的代码将工作表“Projects”的A列中的数据粘贴到工作表“Assignment”的下一个空行中。我希望将其粘贴到工作表“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

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

3 个答案: