Question

我编写了代码来遍历工作簿文件夹并从工作表中提取某些列，然后将数据粘贴到单个工作表中

此代码运行良好，直到第29个工作簿，我想要粘贴在ExtractedColumns工作表底部的数据被粘贴在顶部。其余工作簿也是如此 - 它会覆盖顶部的数据。

将60,000行粘贴到ExtractedColumns工作表后会出现此问题，该行远低于Excel工作表的行号限制。

我无法弄清楚为什么会这样，特别是因为它对前28个工作簿起作用。

这是我的复制和粘贴代码（我没有发布代码来遍历文件夹并打开每个工作簿，因为我觉得代码不会导致问题）：

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

Answer 1

如果要打开一些旧格式的工作簿（限制为65536行），那么您的不合格Rows.Count

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

使该行等同于

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

因此，一旦你的“ExtractedColumns”工作表中有超过65536行，End(xlUp)就会一直向上移动到文件的顶部，并可能将lastRow设置为1（除非你在D列中的第1行下面有一些空单元格。

该行应为

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

始终限定Range，Cells，Rows等，除非您知道您要引用{ {1}}。

Excel VBA：为什么复制/粘贴覆盖其他数据，但只能在60,000行之后？

1 个答案: