Question

我正在尝试从一行开始复制数据，其中单元格的值为“Depth（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

任何帮助都会很棒。谢谢！ -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行的此示例中）确实为空白，就应该完成这项工作。

在空白行结束复制循环时出现1004错误

1 个答案: