セルの位置を移動させてテーブル作成|Excel VBA

埼玉県の郵便番号一覧をネットからコピペして、テーブル作成しました。

f:id:gray-to:20210223195124j:plain

Excelにコピペしたところ、行政区の読み仮名が下にあるので、これを一段上の右セルへ移動して、元の位置が空白行になるので削除、またテーブルにするにあたって要らない行も削除するというVBAです。

f:id:gray-to:20210223195213j:plain

1.読み仮名を右に1列、上に1行ずらすコード

Sub Macro001_01() '///読み仮名を右1、上1へコピペ///  
Dim i As Long For i = 2 To 10000 ’最終行が8490なので10000を指定
If Cells(i, 1) = "" Then Cells(i, 3).Offset(-1, 0) = Cells(i, 2) '
End If Next i End Sub

2.続いて、A列が空白なら行削除するコード

Sub Macro001_02() '///A列が空白なら行削除///  
Dim lRow As Long  
Dim i As Long  
    lRow = Cells(Rows.Count, 1).End(xlUp).Row  
    Application.ScreenUpdating = False  
    For i = lRow To 2 Step -1  
        If Cells(i, 1) Like "" Then  
            Range(i & ":" & i).Delete  
    End If  
    Next i  
    Application.ScreenUpdating = True  
End Sub

3.最後に、それ以外の不要な行を削除するコード

Sub Macro001_03() '///余分な行を削除///  
Dim lRow As Long  
Dim i As Long  
lRow = Cells(Rows.Count, 1).End(xlUp).Row  
Application.ScreenUpdating = False  
    For i = lRow To 2 Step -1  
        If Cells(i, 1) Like "郵便番号の一覧を見る" Or _   
            Cells(i, 1) Like "市区町村" Or _   
            Cells(i, 1) Like "このページの先頭へ戻る" Or _   
            Cells(i, 1) Like "?行" Or _   
            Cells(i, 2) Like "以下に掲載がない場合" Then  
            Range(i & ":" & i).Delete  
        End If  
    Next i  
    Application.ScreenUpdating = True  
End Sub

完成です

f:id:gray-to:20210223200358j:plain