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

列の文字を要件に適した列に変更します。

編集： あなたは正しいです、私が前に与えた答えは不必要な変更でした. Do ... Loop最初の空白行 (5 行目) までしか実行されないため、インスタンス化する前に startrow 変数を参照していましたが、「深さ」テストは 7 行目まで実行されませんでした (したがって、startrow = rownum行は実行されませんでした) 。 . Next rownumそのため、コピー アクションでは、行 0 からコピーするように指示していました。次のようにステートメントの配置を修正することで、これを修正できます。

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 に答える