循环时获取额外的空白行

Question

This is my first time working with VBA, so hopefully this is something easy. I have code that loops through lines on one workbook, copies certain cells, and appends them into a second workbook. It keeps leaving an extra blank line at the end of the pasted data. I assume it has something to do with my for loop, but I have not found anything online that describes this problem.

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

A few things to note:

• If you use.Offset(row,col), you don't need to use i in your For each loop (albeit more useful to just use a normal for loop
• Your lastrow is probably better obtained by

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

• You shouldn't use Select to copy/paste: see: Avoid Select in VBA
• You don't need to use copy/paste in your example, you can just set the values
• You don't need to activate a workbook to change values in its sheets
• PasteSpecial as what? Usually used to get rid of formulas with PasteSpecial xlPasteValues

I know those are a lot of "negatives" but this is meant as helpful criticism. You're doing far better than when I started with vba:)

The reason why you're getting an extra empty row is likely due to the starting value of your 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

Hope I didn't forget anything and used the resizing correctly, I'm still learning myself and unable to test right now.. If anything is unclear, feel free to ask, I'll answer in the morning.

Answer 2

Copy Discontinuous Row Ranges

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