エクセルの列【カラム】を行【レコード】に変換するマクロ

050-VBA

2024.08.18

へっぽこヘタレシステム管理者の管理人です。

さて、仕事の関係ですが・・・

税の口振申請用紙をAI-OCRで読み込んで、

RPAでシステムに入力して欲しいという依頼がありました。

ただ、口振の申請用紙は複数の税目が選択できるため・・・

AI-OCRで申請書を読み込むと・・・

申請者・口座情報・税目１・税目２・税目３・税目４

と税目がカラムになってしまいます。

しかし、システムでは、税目毎に口座が別々に設定できる関係で・・・

申請者・口座情報・税目１
申請者・口座情報・税目２
申請者・口座情報・税目３
申請者・口座情報・税目４

といった感じで税目毎にレコードになっていないと入力できない訳です。

ということで、AI-OCRから出力されたエクセルデータの

列を（カラム）行（レコード）に変換する必要があるわけですが・・・

今回は、とりあえずマクロでゴリ押ししてみることにしました。

なお、同様の事は、EXCEL2016以降であれば、パワークエリ使えば、ノーマクロで可能です。

とりあえずやりたい事は動画を参照してください。

サンプルエクセルはこちらら

ブログランキングにご協力ください！

コードは次の通りです。

Sub henkan()

'シートを追加して名前変更
    Worksheets.Add After:=Sheets(1)
    Sheets(2).Name = "編集後"

    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    
    Set WS1 = Worksheets("元データ")
    Set WS2 = Worksheets("編集後")

'シートの内容を全コピー
    WS1.Cells.Copy
    WS2.Cells.PasteSpecial Paste:=xlPasteAll

    WS2.Range("A1").Select
    
'変数設定
    Dim maxrow As Long  '最終行
    Dim kuricounta As Long  '繰り返し回数
    Dim columnsounta As Long    '税目CDの列
    Dim sagyourow As Long   '作業してる行数
    Dim addrow As Long  '挿入した行数のカウント
    
    columnsounta = 7
    sagyourow = 2
    addrow = 1
    
    maxrow = Cells(Rows.Count, 1).End(xlUp)

    

'以下繰り返し
    For kuricounta = 1 To maxrow '繰り返す回数
    
        For columnsounta = 10 To 7 Step -1  '税目CDの列が空白か調べる
        
                If WS2.Cells(sagyourow, columnsounta) <> "" Then    '税目CD<>空白なら
                    WS2.Rows(sagyourow + 1).Insert Shift:=xlDown    '次の1行に空白行を挿入する
                    
                    WS2.Range(Cells(sagyourow, 1), Cells(sagyourow, 6)).Copy    '連番から口座番号までをコピー
                    WS2.Rows(sagyourow + 1).PasteSpecial Paste:=xlPasteAll  '連番から口座番号までをペースト
                    
                    WS2.Cells(sagyourow, columnsounta).Copy '税目コードをコピー
                    WS2.Cells(sagyourow + 1, 11).Select '最終列にペースト
                    ActiveSheet.Paste
                    
                    addrow = addrow + 1 '挿入した行数のカウント
                    
                Else
                End If
                                
        Next columnsounta
        
        sagyourow = sagyourow + addrow  '挿入した行数を作業する行にプラス
        addrow = 1  '挿入した行数を1に戻す
        
        
        Debug.Print kuricounta
        
    Next kuricounta
    
'最終行のカラムを設定
    WS2.Cells(1, 11) = "税目CD"
    
'フィルタを掛けて税目CDが空白行を消す
    WS2.Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Cells.AutoFilter Field:=11, Criteria1:="="
    
    WS2.Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.EntireRow.Delete
    Selection.AutoFilter

'元の税目CDの列を消す
    WS2.Range("G:J").Delete Shift:=xlToLeft

    WS2.Range("A1").Select

End Sub

かなり適当にマクロを組んだので、思った以上に長くなってしまいました。

ただ、毎日マクロを触っている訳ではないので、結構すぐに忘れてしまい、

簡単なことでも、ググらないと分からないのは、面倒くさい。

インターネットあればすぐに検索できますが、

オフライン環境だとマクロなんて絶対に組めませんね。