在空白行處結束複製循環時出現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 

我真正想要複製是從深度（米）下降到10 33.96到新的工作表。我一直在採摘這一段時間，但無法得到它。調試器指向這條線：

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

任何幫助將是偉大的。謝謝！ -Susan

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行）真的是空白的，就應該完成這項工作。