VBA 空白セルを詰めて別シート転記 2選(動画あり)

エクセルマクロで、空白セルを詰めて別シート転記するVBAコードをご紹介します。

このページのマクロコードは、コピペで使えます。
ぜひお試しください！

空白セルを詰めて別シート転記

以下のExcelVBAを実行すると、空白行を上詰めして転記します。

Sub 空欄をつめて別シート抽出()

Dim LastRow As Long
Dim LastClm As Long
Dim i As Long
Dim j As Long
Dim Q As Long

    '最終行を取得
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    '最終列
    LastClm = Range("A1").End(xlToRight).Column
    
    Q = 1

    '1～最終行までループ
    For i = 1 To LastRow
    
        For j = 1 To LastClm
        
            If Cells(i, j) <> "" Then
            
                Range(Cells(i, 1), Cells(i, LastClm)).Copy Sheets("Sheet2").Cells(Q, 1)
                Q = Q + 1
                Exit For
            
            End If
        Next j
    Next i

 End Sub

マクロ実行前

「Sheet1」の空白セルがわかりやすいように色付けしています。

マクロ実行後

空欄の行を詰めて、別のシートへ転記します。

空白セルを詰めて別シート転記（全セルを詰める）

以下のExcelVBAを実行すると、配列を使用して空白セルを上詰めして指定シートへ転記します。

Sub 空白を上につめて別シート抽出()

Dim i As Long
Dim j As Long
Dim CntA As Long
Dim CntB As Long
Dim MyList As Variant
Dim ChkList As Variant
Dim Sht1 As Worksheet
Dim Sht2 As Worksheet

    Set Sht1 = Sheets("Sheet1")
    Set Sht2 = Sheets("Sheet2")

    CntA = 1
    CntB = 1

    'A～F列のデータを配列格納
    MyList = Sht1.Range("A1", Range("A" & Rows.Count). _
                     End(xlUp)).Resize(, 6).Value

    '配列の大きさ指定
    ReDim ChkList(6, UBound(MyList))

    '配列ループ
    For i = 1 To Sht1.Range("A1").End(xlToRight).Column

        For j = 1 To UBound(MyList)

            '配列が空欄じゃなければ
            If MyList(j, i) <> "" Then

                '配列「ChkList」に値追加
                ChkList(CntA, CntB) = MyList(j, i)
                CntB = CntB + 1

            End If
        Next j

        CntA = CntA + 1
        CntB = 1

    Next i

    '二次元配列をSht2に転記
    For i = 1 To UBound(ChkList)
        For j = 1 To UBound(MyList)
            Sht2.Cells(j, i) = ChkList(i, j)
        Next j
    Next i
 End Sub

マクロ実行後

すべての空欄のセルを詰めて、別シートへ転記します。

 
 
この記事がお役に立ちますと幸いです。
 
・【エクセルマクロ】別シート転記を自動処理する方法まとめ
 

【エクセルマクロ】別シート転記(抽出)を自動化する：超便利20選

...

kirinote.com

2023.02.04