Question

I am trying to copy data starting at a row with cell with value of “Depth (m)” and ending at the next blank row. The number of rows between these will vary and I have 400 spreadsheets to do this on.

The error:

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

Here is my code:

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

It works if change this line:

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

to this:

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

Unfortunately, I can’t use that because that text will vary as well from workbook to workbook.

Here I a sample of my data:

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

What I really want to copy is from Depth (m) down to 10 33.96 to a new sheet. I have been picking at this for a while but can’t get it. The debugger points to this line:

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

Any assistance would be great. Thanks you! -susan

Answer 1

You’re only referencing row numbers in this line:

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

Try changing that to:

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

Change the column letters to the appropriate columns for your requirements.

EDIT:
Correct you are, the answer I gave before was an unnecessary change. What was happening is you were referencing the startrow variable before instantiating it because your Do ... Loop would only run until the first blank line (line 5), whereas the “Depth” test didn’t occur until line 7 (thus, the startrow = rownum line was never run). So, in the Copy action, you were telling it to copy starting at Row 0. You can fix this by correcting the placement of your Next rownum statement like so:

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

EDIT 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

As long as the blank row (in this example in row 19) is truly blank, this should do the job.