ベストアンサー
お疲れ様です。 単純なコードですがこれでいいのではないでしょうか? forは使ってますが11行です済みますよ。 Sub test() Dim i As Long,j As Long j=1 For i=1 To 24 Step 2 If Cells(i,"A") <> "" Then Cells(j,"S")=Cells(i,"A") Cells(j,"W")=Cells(i,"E") j=j+2 End If Next i End Sub
この回答はいかがでしたか? リアクションしてみよう
質問者からのお礼コメント
ありがとうございます。
お礼日時:10/13 6:16
その他の回答(4件)
なぜ1レコードに2行使っているんでしょうか… とりあえず Sub コピー() Dim from_data As Range Set from_data = [A1:E1] Dim Set As Range Set to_data = [S1:W1] For i=1 to 12 If Range.cells(1,1).value <> "" Then to_data = from_data.value Set to_data = to_data.offset(2,0) End If Set from_data = from_data.offset(2,0) Next End sub
Excel方眼紙しておらず M365ならFilter関数で配列データとして取得 貼り付け先のオブジェクトの範囲合わせたうえで代入で済むので For文を使わずに済みます。 (VBAなりのスクリプトのFor文などのループはExcel内の複数処理より遅いのは明確ですから…。)
空白の所に色が塗ってある、ということは空白のセルに数式が入っている可能性が高いです。なので単純な最終セルの取得ではうまくいかないです。 それとセルの結合は書式なので値貼り付けするとセルの結合が解除されてS1セルに貼り付けられます。添付図を見るとそれはうまくないですね。 「最後のセル」から上に「文字数」1以上のセルで最終行を取得します。 セル幅も取得します。 Sub test() Dim i As Long, lastrow As Long, rw As Long lastrow = Cells.SpecialCells(xlCellTypeLastCell).Row For i = lastrow To 1 Step -1 If Len(Cells(i, 1)) > 0 Then rw = i Exit For End If Next Range("A1:H" & rw + 1).Copy Range("S1") Columns("S:Z").ColumnWidth = Columns("A:H").ColumnWidth Range("S1").CurrentRegion.Interior.Color = RGB(210, 210, 210) End Sub
こんな感じになるかと。 Sub Sample() With Range("A1", Cells(Rows.Count, "E").End(xlUp)) Range("S1").Resize(.Rows.Count, .Columns.Count).Value = .Value End With End Sub