Copy Excel Row if Cell is equal to a value

问题

I'm trying to copy and paste into a different workbook and spread that data over different sheets inside of the new workbook. I've got my VBA working, but it only works about 25% of the time. I continually get an error on "Run-time error '1004': Select method of Range class failed".

Here is the script:

Sub CopyData()

    Dim i As Range
    For Each i In Range("A1:A1000")

        Windows("data_1.xls").Activate
        Sheets("data_1").Activate
        If i.Value = 502 Then
            i.Select
            ActiveCell.Rows("1:1").EntireRow.Select
            Selection.Copy
            Windows("DataOne.xls").Activate
            Sheets("502").Range("A39").End(xlUp).Offset(1, 0).PasteSpecial
        End If
        If i.Value = 503 Then
            ........
        End If
     Next i
End Sub

The failure happens on i.Select every time. Do I need to bring Next i up to the end of every End If?

回答1:

You don't need to use Activate, Select, or copy/paste if you just want to transfer values.

Sub CopyData()

    Dim i As Range
    Dim srcBook as Workbook
    Dim destBook as Workbook

    Application.ScreenUpdating = False

    Set srcBook = Workbooks("data_1.xls")
    Set destBook = Workbooks("DataOne.xls")

    For Each i In srcBook.Sheets("data_1").Range("A1:A1000")
        Select Case i.Value
            Case 502
                destBook.Sheets("502").Range("A39").End(xlUp). _
                    Offset(1, 0).EntireRow.Value = i.EntireRow.Value
            Case 503
                destBook.Sheets("503").Range("A39").End(xlUp). _
                    Offset(1, 0).EntireRow.Value = i.EntireRow.Value
            Case 504
                'etc
            Case Else 
                'do nothing/ or do something for non-matching
        End Select
     Next i

    Application.ScreenUpdating = True
End Sub

This could maybe be further simplified if I knew more about your If/Then structure and the destination of the values (are they all going to a sheet name in the same file, which corresponds to the value of i? If so, this could be even more simple.

I am curious why you're looping a range of 1000 rows, but only writing to a range of A39 (.End(xlUp))...

Updated from comments:

Sub CopyData()

    Dim i As Range
    Dim srcBook as Workbook
    Dim destBook as Workbook
    Set srcBook = Workbooks("data_1.xls")
    Set destBook = Workbooks("DataOne.xls")

    For Each i In srcBook.Sheets("data_1").Range("A1:A1000")
        destBook.Sheets(Cstr(i)).Range("A:A").End(xlUp).Offset(1,0). _
            EntireRow.Value = i.EntireRow.Value
     Next i
End Sub

You probably don't need to worry about ScreenUpdating with this size of an array, and using this direct method to write from/to the destination, it's not nearly as resource-intensive as continuously selecting, activating, copying/pasting and then selecting again, etc.

回答2:

When you activate another sheet/window, you confuse the loop. The next i ends up referring to the next cell in the wrong sheet, which may have no value in.

If you do have to Activate, make sure you go back to the original sheet before the next round in the loop. Which means you REALLY need Application.ScreenUpdating = False at the start of your sub, and Application.ScreenUpdating = True at the end...

来源：https://stackoverflow.com/questions/19125372/copy-excel-row-if-cell-is-equal-to-a-value

标签

excel

vba

excel-vba