経緯

お客様から、「ユーザIDに複数の店コード紐付けたいのでDBに登録して欲しい」という依頼があり、Excelに記載された下記のようなデータ¹が送られてきました。

‥‥非常に困りました。いつもは下記スクショのように文字列結合した式をオートフィルしてINSERT文を作っているのですが、その手法が使えません。

全てのデータを赤枠で囲ったような縦並びにしたいのですが、データは180行分あるため手でやると時間もかかるしミスもしそうです。そのためマクロを作成することにしました。

作成したコード

早速ですが、下記が作成したマクロです。
シート「original」にある元データをコピーし、シート「target」に縦並びで貼り付けます。
行によっては店コードの入力欄が空白であるセルもあるため、一旦配列に格納した後空白の要素を削除する処理も入れてます。VBA Create様の配列から空白(Empty)を削除する【ExcelVBA】よりお借りしました。

苦労したところは配列の操作です。ただでさえ苦手意識があるのに動的配列という存在に混乱させられました。

Option Explicit

'メイン関数
Sub normalization()

'コピー実行回数(ループ回数)
Dim count_of_copy As Integer
'コピー元ワークシート「original」
Dim sheet_original As Worksheet
'貼り付け先ワークシート「target」
Dim sheet_target As Worksheet
'originalのコピースタート位置
Dim low_number_of_start_original As Integer
'targetの貼り付けスタート位置
Dim low_number_of_start_target As Integer
'ユーザID
Dim user_cd As String
'店コード
Dim shop_cd As String

'ワークシートの有効化
Set sheet_original = Worksheets("original")
Set sheet_target = Worksheets("target")


'ループ処理開始。originalの180行分繰り返す
For count_of_copy = 1 To 180


    '初回処理

        '初回実行の場合、それぞれのシートの開始位置を指定
        If count_of_copy = 1 Then
            low_number_of_start_original = 1
            low_number_of_start_target = 0

        End If

    'シート「original」の値取得

        '対象セルが空白の場合、ユーザID取得処理はスキップする。以前のループで取得したユーザIDが保持される
        If sheet_original.Cells(low_number_of_start_original, "A").Value <> "" Then

            'A列のlow_number_of_start_original行目のユーザIDを取得。
            user_cd = sheet_original.Cells(low_number_of_start_original, "A").Value

        End If
        Debug.Print (user_cd)

        '店コードを格納する動的配列の定義
        Dim array_of_shop() As Variant
        ReDim array_of_shop(26)

        'B～AA列まで26列あるため、店コードを取得して配列に格納する処理を26回分繰り返す
        Dim i As Integer
        For i = 0 To 25

            '店コードを取得
            shop_cd = sheet_original.Cells(low_number_of_start_original, i + 2).Value

            '配列に代入
            array_of_shop(i) = shop_cd

        Next i

        '配列から空白の要素を削除する処理
        array_of_shop = Call_Array_DeleteEmpty(array_of_shop)

        '空白要素削除後の配列の要素数を定義
        'UBoundは配列の最大のインデックス値を返すため、実際の要素数はUBound+1
        Dim element_count_of_array_of_shop As Integer
        element_count_of_array_of_shop = UBound(array_of_shop) + 1


    'シート「target」へのコピー処理
        For i = 1 To element_count_of_array_of_shop

            'シート「target」のA列にユーザIDの値を貼り付ける
            sheet_target.Cells(low_number_of_start_target + i, "A") = user_cd

             'シート「target」のB列に配列に格納した店コードを貼り付ける
            sheet_target.Cells(low_number_of_start_target + i, "B") = array_of_shop(i - 1)

        Next i

    'コピー終了処理

        'シート「original」のコピー開始位置を取得
        low_number_of_start_original = low_number_of_start_original + 1

        'シート「target」において、貼付けの開始位置を取得
        low_number_of_start_target = low_number_of_start_target + element_count_of_array_of_shop

Next count_of_copy

End Sub

'配列から空白を削除する関数
Public Function Call_Array_DeleteEmpty(arr As Variant)
     Dim i As Long
     Dim temp As Variant
     Dim tRow As Variant

     ReDim temp(UBound(arr))

     For Each tRow In arr
        '■tRowが空白以外であれば、temp配列に格納する
        If Not IsEmpty(tRow) Then
            If tRow <> "" Then
                temp(i) = tRow
                i = i + 1
            End If
        End If
     Next
     '■tempを空白を除いた分で再定義
     ReDim Preserve temp(i - 1)
     Call_Array_DeleteEmpty = temp
End Function

感想

作成時間は4時間30分(処理フロー構想45分、実装3時間45分)と結構かかってしまいましたが、書き方が全くわからない状態からスタートした割には上手く形になったのではないかと思います。
これくらいのコードを爆速で書き、業務を自動化出来たら非常にかっこいいだろうなと思いました。余裕があったら目指してみたいです。

スクショのデータは分かりやすくするため自作したデータです。 ↩