1

我正在尝试从值为“深度（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

任何帮助都会很棒。谢谢！-苏珊

4

1 回答 1

0

您仅在此行中引用行号： 

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

尝试将其更改为：

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

根据您的要求将列字母更改为适当的列。

编辑： 你是对的，我之前给出的答案是不必要的改变。发生的事情是您在实例化它之前引用了 startrow 变量，因为您Do ... Loop只会运行到第一个空白行（第 5 行），而“深度”测试直到第 7 行才发生（因此，该startrow = rownum行从未运行） . 因此，在 Copy 操作中，您告诉它从第 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 行）确实是空白的，这应该可以完成工作。

于 2012-11-30T00:13:31.940 回答