CODEWITHSUNDEEP
vbaexcel
studiis
studiis

Reputation: 95

Excel VBA: why is copy/paste overwriting other data, but only after 60,000 rows?

I've written code to loop through a folder of workbooks and extract certain columns from their worksheets then paste the data onto a single worksheet

This code was working well until the 29th workbook, where the data that I wanted pasted at the bottom of my ExtractedColumns worksheet was instead pasted at the top. The same happened for the remaining workbooks- it overwrites the data that is at the top.

This problem occurs after 60,000 rows have been pasted into the ExtractedColumns worksheet, which is well below the limit on row numbers for an Excel worksheet.

I can't figure out why this is happening, especially because it's working fine for the first 28 workbooks.

Here's my code for copying and pasting (I'm not posting the code to loop through the folder and open each workbook, because I feel like that code isn't causing the problem): 

Sub extract()
Dim curr As Range
Dim cell As Range
Dim lastRow As Variant
Dim n As Long
Dim found As Boolean
Dim FirstRow As Range
Dim wbOpen As Object

found = False
Set wbOpen = Workbooks("ExtractedColumns")

'finds where data starts
 For i = 3 To 50
    If Not IsEmpty(Cells(i, "E")) Then
        Exit For
    End If
Next
'    Next
'Par B name: if there is a header with one of these names, then it extracts those
    For Each curr In Range("A" & i, "Z" & i)
        If InStr(1, curr.Value, "Protein name", vbTextCompare) > 0 Or InStr(1, curr.Value, "description", vbTextCompare) > 0 Or InStr(1, curr.Value, "Common name", vbTextCompare) > 0 Then
            lastRow = wbOpen.Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
            Range(curr.Offset(1), Cells(Rows.Count, curr.Column).End(xlUp)).Copy Destination:=wbOpen.Sheets("Sheet1").Range("D" & lastRow + 1)
            found = True
            Exit For
        End If
    Next
    'If there isn't a header with one of the above names, then see if there is one with the name "protein"
    If Not found Then
        For Each curr In Range("A" & i, "Z" & i)
            If InStr(1, curr.Value, "protein", vbTextCompare) > 0 Then
               lastRow = wbOpen.Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
                Range(curr.Offset(1), Cells(Rows.Count, curr.Column).End(xlUp)).Copy Destination:=wbOpen.Sheets("Sheet1").Range("D" & lastRow + 1)
                Exit For
            End If
        Next

    End If
'Par B accession
For Each curr In Range("A" & i, "Z" & i)
         If InStr(1, curr.Value, "accession", vbTextCompare) > 0 Or InStr(1, curr.Value, "Uniprot", vbTextCompare) > 0 Or InStr(1, curr.Value, "IPI") > 0 Then
           lastRow = wbOpen.Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row
            Range(curr.Offset(1), Cells(Rows.Count, curr.Column).End(xlUp)).Copy Destination:=wbOpen.Sheets("Sheet1").Range("E" & lastRow + 1)
            found = True
            Exit For
        End If
    Next

'Par B site
For Each curr In Range("A" & i, "Z" & i)
         If (UCase(curr.Value) = "RESIDUE" Or UCase(curr.Value) = "POSITION" Or UCase(curr.Value) = "POSITIONS" Or InStr(1, curr.Value, "Positions within protein", vbTextCompare) > 0 Or InStr(1, curr.Value, "Position in peptide", vbTextCompare) Or InStr(1, curr.Value, "Site", vbTextCompare) > 0) And (InStr(1, curr.Value, "modification", vbTextCompare) = 0 And InStr(1, curr.Value, "ERK") = 0 And InStr(1, curr.Value, "class", vbTextCompare) = 0) Then
           lastRow = wbOpen.Sheets("Sheet1").Cells(Rows.Count, "G").End(xlUp).Row
            Range(curr.Offset(1), Cells(Rows.Count, curr.Column).End(xlUp)).Copy Destination:=wbOpen.Sheets("Sheet1").Range("G" & lastRow + 1)
            Exit For
        End If
Next

'puts dashes in any blank cells in the columns (so spreadsheet isn't ragged)
    n = wbOpen.Sheets("Sheet1").UsedRange.Rows(wbOpen.Sheets("Sheet1").UsedRange.Rows.Count).Row
    For Each curr In wbOpen.Sheets("Sheet1").Range("D2:D" & n)
        If curr.Value = "" Then curr.Value = " - "
    Next
    For Each curr In wbOpen.Sheets("Sheet1").Range("E2:E" & n)
        If curr.Value = "" Then curr.Value = " - "
    Next
    For Each curr In wbOpen.Sheets("Sheet1").Range("G2:G" & n)
        If curr.Value = "" Then curr.Value = " - "
    Next
'puts "x" in first empty row (filename will go in column A in this row)
    n = wbOpen.Sheets("Sheet1").UsedRange.Rows(wbOpen.Sheets("Sheet1").UsedRange.Rows.Count + 1).Row
    For Each curr In wbOpen.Sheets("Sheet1").Range("D2:D" & n)
        If curr.Value = "" Then curr.Value = "x"
    Next
    For Each curr In wbOpen.Sheets("Sheet1").Range("E2:E" & n)
        If curr.Value = "" Then curr.Value = "x"
    Next
    For Each curr In wbOpen.Sheets("Sheet1").Range("G2:G" & n)
        If curr.Value = "" Then curr.Value = "x"
    Next
End Sub

Upvotes: 1

Views: 1094

Answers (1)

YowE3K
YowE3K

Reputation: 23974

If you are opening up some old format workbooks (which have a limit of 65536 rows) then your unqualified Rows.Count in

lastRow = wbOpen.Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row

is making that line equivalent to

lastRow = wbOpen.Sheets("Sheet1").Cells(65536, "D").End(xlUp).Row

So, once you have more than 65536 rows in your "ExtractedColumns" worksheet, the End(xlUp) is moving all the way up to the top of the file and probably setting lastRow to 1 (unless you have some empty cells below row 1 in column D).

That line should be

lastRow = wbOpen.Sheets("Sheet1").Cells(wbOpen.Sheets("Sheet1").Rows.C‌​ount, "D").End(xlUp).Row

Always qualify Range, Cells, Rows, etc, unless you know that you want to refer to the ActiveSheet.

Upvotes: 3

Related Questions