Copy lines in For Loop and Paste into a new sheet

advertisements

I am having problems copy/pasting rows based on criteria.

Dim lastrow1 As Long
Dim lastcolumn1 As Long
Dim Distance As Long
Distance = 14
Set sh = ThisWorkbook.Sheets("Sample Address Database")
Set sh2 = ThisWorkbook.Sheets("Workspace")
lastrow1 = sh.Cells(Rows.Count, "A").End(xlUp).row
lastcolumn1 = sh.Cells(1, Columns.Count).End(xlToLeft).Column

Dim L As Long
For L = 2 To lastrow1
    If _
    sh.Cells(L, Distance).Value <= CDbl(cboRadius.Value) Then
        sh.Range("A" & L & ":" & lastcolumn1 & L).Copy _
        Destination:=sh2.Range("A" & L)
    End If
Next

cboRadius.Value is a number from a userform (there is no problem with that line.)

Whenever I try to run this code, I get a "Run-time error '1004': Method 'Range' of object '_Worksheet' failed, with the yellow arrow pointing to the destination line. What is the problem?

EDIT: Ed Heywood-Lonsdale suggested I change

sh.Range("A" & L & ":" & lastcolumn1 & L).Copy _

To

sh.Range("A" & L & ":A" & lastcolumn1 & L).Copy _

Now only column A, or if I change it to B, C, D, etc. is being copied. I think the problem is that it may not be registering that lastcolumn1 and L are column/row numbers and is instead making them one value, thus causing a range malfunction.


I would just filter your data in place using the built in Excel Filters, then copy the results over instead of trying to Loop over every row.

BUT If you want to loop the rows anyways:

In order to use the Range function you need to use column letters not column numbers.

You have 2 options here. Use

Chr(lastcolumn1 + 64)

instead of lastcolumn1. The flaw is This will only work for columns up to columns Z, and it won't work for double letter columns without an if statement and more code. Like the following should work for up to Column ZZZ

If lastcolumn1> 52 Then
    strColumnLetter = Chr(Int((lastcolumn1- 1) / 52) + 64) & Chr(Int((lastcolumn1- 27) / 26) + 64) & Chr(Int((lastcolumn1- 27) Mod 26) + 65)
ElseIf lastcolumn1> 26 Then
    strColumnLetter = Chr(Int((lastcolumn1- 1) / 26) + 64) & Chr(Int((lastcolumn1- 1) Mod 26) + 65)
Else
    strColumnLetter = Chr(lastcolumn1+ 64)
End If

But you could also use

strColumnLetter = Split(Cells(1, lastcolumn1).EntireColumn.Address(False, False), ":")(0)

OR

strColumnLetter = Left(Replace(Cells(1, lastcolumn1).Address(1, 0), "$", ""), InStr(1, Replace(Cells(1, lastcolumn1).Address(1, 0), "$", ""), 1) - 1)

OR

strColumnLetter = Left(Cells(1, lastcolumn1).Address(1, 0), InStr(1, Cells(1, lastcolumn1).Address(1, 0), "$") - 1)

as that will work for as many columns as Excel will hold.

Your last option if you don't want to convert the number to the column Letter would be to get a range of Cells, as the Cells function CAN accept column numbers for arguments.

sh.Range(cells(L,1), cells(L,lastcolumn1))

Again I would suggest just using the standard built in filter function to filter out the data you don't want then just copy whats left though. This was just to add more options.

If you supply some sample info I could write you a sub that will do the filter copy paste for you but I don't know how your data is set up.

here is an example that should work based on your Original Question:

Sub FilterAndCopy()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim sh As Worksheet, sh2 As Worksheet
Dim lastrow1 As Long
Dim lastcolumn1 As Long
Dim Distance As Long
Distance = 14

Set sh = ThisWorkbook.Sheets("Sample Address Database")
Set sh2 = ThisWorkbook.Sheets("Workspace")

lastrow1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
lastcolumn1 = sh.Cells(1, Columns.Count).End(xlToLeft).Column

With sh
    .Range(.Cells(1, 1), .Cells(lastrow1, lastcolumn1)).AutoFilter , _
    field:=Distance, _
    Criteria1:="<=" & CDbl(151), _
    Operator:=xlAnd

    .Range(.Cells(2, 1), .Cells(lastrow1, lastcolumn1)).Copy _
    sh2.Range("A2")

End With

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub