在空白行結束復制循環時出現1004錯誤

Question

我正在嘗試從單元格的值“深度（m）”的行開始復制數據，並在下一個空白行結束。 這些之間的行數會有所不同，我有400個電子表格可以執行此操作。

錯誤：

Run-time error '1004':
Application-defined or object-defined error

這是我的代碼：

Sub CopyDepth()
   Dim rownum As Long

   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   rownum = 1
   colnum = 1
   lastrow = Worksheets("Profile").Range("A65536").End(xlUp).Row
   With ActiveWorkbook.Worksheets("Profile").Range("a1:a" & lastrow)

   For rownum = 1 To lastrow
    Do
       If .Cells(rownum, 1).Value = "Depth (m)" Then
          startrow = rownum
       End If

       rownum = rownum + 1

   If (rownum > lastrow) Then Exit For

   Loop Until .Cells(rownum, 1).Value = ""
   endrow = rownum
   rownum = rownum + 1

   Worksheets("Profile").Range(startrow & ":" & endrow).Copy

   Sheets("data").Select
   Range("A1").Select
   ActiveSheet.Paste

   Next rownum
   End With
   End Sub

如果更改此行，它將起作用：

Loop Until .Cells(rownum, 1).Value = ""

對此：

Loop Until .Cells(rownum, 1).Value = "Doe (Jane, corrected):"

不幸的是，我不能使用它，因為每個工作簿中的文本也會有所不同。

在這里，我是我的數據樣本：

Big Lake
29 October, 2012
Joe & Jill
Blue [Big] Lake, Utah (USA)

OLD meter (#00314)
Depth (m)   T (deg-C)
0   31.21
1   32.64
2   34.70
3   36.76
4   36.92
5   36.92
6   36.12
7   35.47
8   35.05
9   34.32
10  33.96

Doe (Jane, corrected):
N: 8.0m
S: 8.0m

我真正想要復制的是從深度（m）到10 33.96的新紙。 我已經選擇了一段時間了，但是無法實現。 調試器指向此行：

Worksheets("Profile").Range(startrow & ":" & endrow).Copy

任何幫助都會很棒。 謝謝！ -蘇珊

Answer 1

您僅在此行中引用行號：

Worksheets("Profile").Range(startrow & ":" & endrow).Copy

嘗試將其更改為：

Worksheets("Profile").Range("A" & startrow & ":B" & endrow).Copy

將列字母更改為適合您的要求的列。

編輯：正確的是，我之前給出的答案是不必要的更改。 發生的事情是您在實例化實例之前就引用了startrow變量，因為Do ... Loop將一直運行到第一個空白行（第5行），而“深度”測試直到第7行才發生（因此， startrow = rownum行從未運行過）。 因此，在“復制”操作中，您告訴它從第0行開始復制。您可以通過更正Next rownum語句的位置來解決此問題，如下所示：

Sub CopyDepth()
   Dim rownum As Long

   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   rownum = 1
   colnum = 1
   lastrow = Worksheets("Profile").Range("A65536").End(xlUp).Row
   With ActiveWorkbook.Worksheets("Profile").Range("a1:a" & lastrow)

   For rownum = 1 To lastrow
     Do
       If .Cells(rownum, 1).Value = "Depth (m)" Then
          startrow = rownum
       End If

       rownum = rownum + 1

       If (rownum > lastrow) Then Exit For

     Loop Until .Cells(rownum, 1).Value = ""
     endrow = rownum
     rownum = rownum + 1
   Next rownum

   Worksheets("Profile").Range(startrow & ":" & endrow).Copy
   Worksheets("data").Range("A1").PasteSpecial
   End With
End Sub

編輯2：

Sub CopyDepth()
    Dim ws As Worksheet
    Dim rng As Range
    Set ws = Worksheets("Profile")
    Set rng = ws.UsedRange.Find(What:="Depth (m)")
    Range(rng, rng.End(xlToRight).End(xlDown)).Copy
    Worksheets("data").Range("A1").PasteSpecial
End Sub

只要空白行（在此示例中為第19行）真正為空白，就可以完成此工作。