不規則なデータ行から、最初の2行だけを取り出して別のシートに貼りつけたい

Question

こんにちわ。相変わらずEXCEL初心者から抜け出せない初心者です。

CODE毎に不規則にデータが蓄積されてくるCSVファイルがあります。そこから、上から2つの行だけを取り出して、別のシート（Sheet1）に行を転記させたいのです。（2つ画像を貼りつけていますが、上の一個目が元のCSVファイル、二個目がやりたい事のイメージファイルです）

以前、teratailにて教えて頂いたコードをなんとか自分で改良しようとがんばっているのですが、2日間エラーから抜け出せません。何が間違っているのでしょうか？？　自分の愚かさに涙が出ています。。

Sub Filter()
   Dim ws As Worksheet, c As Range, i As Integer
   
   i = 2
   
    Set ws = Worksheets("元CSV")
    For Each c In ws.Cells.Resize(, 2).Cells.SpecialCells(xlCellTypeConstants)
        With c.CurrentRegion.Resize(2, 16)
                       
            c.CurrentRegion.Resize(2, 16).copy Destination:=Worksheets("Sheet1").Range("A" & i)
            i = i + 3

        
        End With
    Next
End Sub

Comments

[meg_]

読みずらいのでコードは「コードの挿入」で記入してください。

[Masarukun]

すいません、コードの挿入をしてみました

[meg_]

> 2日間エラーから抜け出せません。
どの行でどんなエラーが出ているのでしょうか？

Answer 1

下記のコードでどうでしょう。

Sub Filter()
    Dim ws As Worksheet, c As Range, i As Long, h As Long
    i = 1: h = 3
    Set ws = Worksheets("元CSV")
    For Each c In ws.Cells.SpecialCells(xlCellTypeConstants).Areas
            c.Resize(h).Copy Destination:=Worksheets("Sheet2").Range("A" & i)
            i = i + h + 1: h = 2
    Next
End Sub

Comments

[Masarukun]

すいません、出力が異なりました。。Areaっていうのがあるんですね。ちょっと考えてみます。

Answer 2

こんな感じでしょうか。

Sub sample()
    Dim ws As Worksheet
    Set ws = Worksheets("元CSV")
    Dim c As Range, rowSize, outRow
    rowSize = 3
    outRow = 1
    For Each c In ws.Cells.Resize(, 1).SpecialCells(xlCellTypeConstants).Areas
        c.Resize(rowSize, 16).Copy Worksheets("Sheet1").Cells(outRow, 1)
        outRow = outRow + rowSize + 1
        rowSize = 2
    Next
End Sub