循环时获取额外的空白行

Question

这是我第一次使用 VBA，所以希望这很容易。 我有代码循环遍历一个工作簿上的行，复制某些单元格，并将它们附加到第二个工作簿中。 它会在粘贴数据的末尾留下一个额外的空行。 我认为它与我的 for 循环有关，但我没有在网上找到任何描述此问题的内容。

For Each agentRow In Range("A4:A45")
Workbooks("Agent.xlsx").Activate
    'Check to see if the agent is active this month
    If Range("D" & i).Value > 10 And Range("E" & i).Value > 10 Then
        'If so, copy this data
        Range("A" & i & ", D" & i & ":R" & i & ", U" & i & ":Z" & i).Select
        Selection.Copy

        'Goto the workbook that will store the data
        Workbooks("Agent Stats Monthly.xlsm").Activate
    
        'Find the last row with data, then paste onto the next row
        findLastRow = 1 + Range("A:A").SpecialCells(xlCellTypeLastCell).Row

        Range("A" & findLastRow).PasteSpecial
    End If
i = i + 1
Next agentRow

Answer 1

有几点需要注意：

• 如果您使用.Offset(row,col)，则无需在 For each 循环中使用 i（尽管使用普通的 for 循环更有用
• 你的 lastrow 可能更好地获得

Workbooks("Agent Stats Monthly.xlsm").Sheets("YourSheetWithData").Range("A" & Rows.Count).End(xlUp).Row

• 您不应该使用 Select 来复制/粘贴：请参阅： Avoid Select in VBA
• 您不需要在示例中使用复制/粘贴，只需设置值即可
• 您无需激活工作簿即可更改其工作表中的值
• PasteSpecial 是什么？ 通常用于使用PasteSpecial xlPasteValues去除公式

我知道这些是很多“负面”，但这是有益的批评。 你比我开始使用 vba 时做得更好:)

你得到一个额外的空行的原因可能是由于你的起始值i

Workbooks("Agent.xlsx").Activate
Dim wbS As Workbook: Set wbS = Workbooks("Agent Stats Monthly.xlsm")
Dim wsS As Worksheet: Set wsS = wbS.Sheets("YourDataSheet")
Dim lRowS As Long
lRowS = wsS.Range("A" & Rows.Count).End(xlUp).Row
For Each agentRow In Range("A4:A45")
    i = agentRow.Row 'I'm assuming that agentRow is a Range object since it's in Range("A4:A45")
    'Check to see if the agent is active this month
    If Range("D" & i).Value > 10 And Range("E" & i).Value > 10 Then
        'If so, copy this data
        lRowS = lRowS+1 'only add +1 if you're going to add a row to your DataSheet
        wsS.Range("A" & lRowS).Resize(1,5).Value = Range("A" & i & ", D" & i & ":R" & i & ", U" & i & ":Z" & i).Value
    End If
Next agentRow

希望我没有忘记任何东西并正确使用调整大小，我还在学习自己，现在无法测试。如果有任何不清楚的地方，请随时提问，我会在早上回答。

Answer 2

复制不连续的行范围

Sub CopyAgentData()
     
    ' Source
    Dim swb As Workbook: Set swb = Workbooks("Agent.xlsx")
    Dim sws As Worksheet: Set sws = swb.Sheets("Sheet1") ' adjust!
    Dim srg As Range: Set srg = sws.Range("D4:E45") ' read
    Dim scrg As Range: Set scrg = Intersect( _
        srg.Rows(1).EntireRow, sws.Range("A:A,D:R,U:Z")) ' copy (first row)
    
    ' Destination
    Dim dwb As Workbook: Set dwb = Workbooks("Agent Stats Monthly.xlsm")
    ' If this code is in this workbook, instead use:
    'Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Sheets("Sheet1") ' adjust!
    Dim dfCell As Range: Set dfCell = dws.Range("A2")
    Dim dlCell As Range: Set dlCell = dws.UsedRange _
        .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If Not dlCell Is Nothing Then
        If dfCell.Row <= dlCell.Row Then
            Set dfCell = dws.Cells(dlCell.Row + 1, dfCell.Column)
        End If
    End If
    
    ' Loop.
    
    Dim srrg As Range ' Current Read Row Range

    For Each srrg In srg.Rows
        'Check to see if the agent is active this month
        If srrg.Cells(1).Value > 10 And srrg.Cells(2).Value > 10 Then
            'If so, copy this data
            'Debug.Print srrg.Address, scrg.Address, dfCell.Address
            scrg.Copy dfCell
            Set dfCell = dfCell.Offset(1) ' next first destination cell
        End If
        Set scrg = scrg.Offset(1) ' next source copy row range
    Next srrg

End Sub