【VBA】データを分割（統合）ための極意【パターン化によるデータ分割】

かんたんだけどしっかりわかるExcelマクロ・VBA入門短時間で身につく忙しい人のためのエクセルの教科書 [ 古川順平 ]
ジャンル: 本・雑誌・コミック > PC・システム開発 > その他
ショップ: 楽天ブックス
価格: 2,138円
' 名称を明確に統一（変更しました。）
' TARGET:分割される側につける（接頭or接尾）
' NEWRNG:分割する側につける（接頭or接尾）
' CRNT:カレント行
' PREV:１個前の行
' NEXT:１個次の行

' ★.NET版に改良する予定-シートをDATAGridViewに置き換える予定。（課題：コピー＆行の挿入方法）' ★

' １個データごとに処理したらTrueになる
' 開始
Public sOK As Boolean
' 終了
Public eOK As Boolean

' 分割する側の列：NEWRNG
Const COL_START_NEWRNG = "A"
Const COL_END_NEWRNG = "B"

' 分割される側の列：TARGET
Const COL_START_TARGET = "B"
Const COL_END_TARGET = "C"

' ■テスト■用コールSUB
Public Sub Execute_For_Debug()
    Call SplitRowData(ThisWorkbook.Sheets("TARGET"), ThisWorkbook.Sheets("NEWR"))
End Sub

' @
' @
' @ wsTARGET:分割される側のシート
' @ wsNEWRNG:分割する側のシート
' @
Public Sub SplitRowData(ByRef WS_TARGET_ As Worksheet, ByRef WS_NEWRNG_ As Worksheet)
    ' 分割される側のシート
    Dim wsTARGET As Worksheet
    ' 分割する側のシート
    Dim wsNEWRNG As Worksheet

    ' 分割される側のインデックス
    Dim idx_TARGET As Long
    '分割する側のインデックス
    Dim idx_NEWRNG As Long
    'ワークシートの設定
    Set wsTARGET = WS_TARGET_
    Set wsNEWRNG = WS_NEWRNG_

    ' 分割する側(NEWRNG)のデータ側でループ
    For idx_NEWRNG = 1 To 10000
        DoEvents
        ' フラグ初期化
        sOK = False
        eOK = False

        'カレントデータを保存
        Dim strSTART_NEWRNG_CRNT As String
        Dim strEND_NEWRNG_CRNT As String

        '分割する側のデータを取得（カレント）
        strSTART_NEWRNG_CRNT = wsNEWRNG.Range(COL_START_NEWRNG & idx_NEWRNG).Text
        strEND_NEWRNG_CRNT = wsNEWRNG.Range(COL_END_NEWRNG & idx_NEWRNG).Text

        '分割する側が空白になったら終了
        If strEND_NEWRNG_CRNT = "" Or strSTART_NEWRNG_CRNT = "" Then
            Exit Sub
        End If

        ' 分割される側(TARGET)でループ
        For idx_TARGET = 1 To 10000
            DoEvents
            '一個前のデータ
            Dim strSTART_TARGET_PREV As String
            Dim strEND_TARGET_PREV As String
            'カレントデータ
            Dim strSTART_TARGET_CRNT As String
            Dim strEND_TARGET_CRNT As String
            '次のデータ
            Dim strSTART_TARGET_NEXT As String
            Dim strEND_TARGET_NEXT As String

            '一個前のデータを取得
            If idx_TARGET > 1 Then
                strSTART_TARGET_PREV = wsTARGET.Range(COL_START_TARGET & (idx_TARGET - 1)).Text
                strEND_TARGET_PREV = wsTARGET.Range(COL_END_TARGET & (idx_TARGET - 1)).Text
            End If

            'カレントデータ取得
            strSTART_TARGET_CRNT = wsTARGET.Range(COL_START_TARGET & idx_TARGET).Text
            strEND_TARGET_CRNT = wsTARGET.Range(COL_END_TARGET & idx_TARGET).Text
            '次の行のデータ
            strSTART_TARGET_NEXT = wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Text
            strEND_TARGET_NEXT = wsTARGET.Range(COL_END_TARGET & (idx_TARGET + 1)).Text

            '空白に達したらループを抜ける
            If strSTART_TARGET_CRNT = "" Or strSTART_TARGET_CRNT = "" Then
                GoTo CONT_FOR1:
            End If

            '
            '   まず全体のチェックから始める
            '   ①   範囲が完全一致
            If (strSTART_NEWRNG_CRNT = strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT = strEND_TARGET_CRNT) Then
                sOK = True
                eOK = True
                GoTo CONT_FOR1
            End If

            '   ②  範囲が完全に含まれる 挿入×2 S2にS   E2にE   E1にS-1 S3にE+1
            If (strSTART_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strEND_TARGET_CRNT) Then
                sOK = True
                eOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にS
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strSTART_NEWRNG_CRNT
                ' E2にE
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET + 1)).Value = strEND_NEWRNG_CRNT
                ' E1にS-1
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = Format(CLng(strSTART_NEWRNG_CRNT) - 1, "000000")
                ' S3にE+1
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 2)).Value = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If

            ' ③　行を跨いで完全に含まれる
            If (strSTART_NEWRNG_CRNT > strEND_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strSTART_TARGET_NEXT) Then
                sOK = True
                eOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にS
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strSTART_NEWRNG_CRNT
                ' E2にE
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET + 1)).Value = strEND_NEWRNG_CRNT
                ' 処理終わり
                GoTo CONT_FOR1
            End If

            '
            '■■■■開始（START）番号チェック■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
            '①strSTART_NEWRNG_CRNTとstrSTART_TARGET_CRNTが一致したら、
            '　1行下に挿入
            '　現行の終了にstrSTART_NEWRNG_CRNTに設定
            '　次行の開始に(strSTART_NEWRNG_CRNT + 1)を設定
            If (strSTART_NEWRNG_CRNT = strSTART_TARGET_CRNT) Then
                sOK = True
                ' ただし現行終了(NEWRNG)が現行終了(TARGET)を超えていたら分割不要
                If (strEND_TARGET_CRNT < strEND_NEWRNG_CRNT) Then
                    ' 処理終わり
                    GoTo TO_END1
                End If
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　現行の終了にstrSTART_NEWRNG_CRNTに設定
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = strSTART_NEWRNG_CRNT
                '　次行の開始に(strSTART_NEWRNG_CRNT + 1)を設定
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = Format(CLng(strSTART_NEWRNG_CRNT) + 1, "000000")
                ' 処理終わり
                GoTo TO_END1
            End If
            '②strSTART_NEWRNG_CRNTとstrEND_TARGET_CRNTが一致
            '　1行下に挿入
            '　次行の開始にstrSTART_NEWRNG_CRNTセット
            '　現業の終了に(strSTART_NEWRNG_CRNT - 1)セット
            If (strSTART_NEWRNG_CRNT = strEND_TARGET_CRNT) Then
                sOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にSセット
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strSTART_NEWRNG_CRNT
                '　次行の開始にstrSTART_NEWRNG_CRNTセット
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = Format(CLng(strSTART_NEWRNG_CRNT) - 1, "000000")
                '　現業の終了に(strSTART_NEWRNG_CRNT - 1)セット
                GoTo TO_END1
            End If
            '③開始と終了に挟まれる場合 strSTART_TARGET_CRNT　＜  strSTART_NEWRNG_CRNT ＜  strEND_TARGET_CRNT
            '　1行下に挿入
            '　次行の開始にstrSTART_NEWRNG_CRNTセット
            '　現業の終了に(strSTART_NEWRNG_CRNT - 1)
            If (strSTART_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strSTART_NEWRNG_CRNT < strEND_TARGET_CRNT) Then
                sOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　次行の開始にstrSTART_NEWRNG_CRNTセット
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strSTART_NEWRNG_CRNT
                '　現業の終了に(strSTART_NEWRNG_CRNT - 1)
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = Format(CLng(strSTART_NEWRNG_CRNT) - 1, "000000")
                ' 処理終わり
                GoTo TO_END1
            End If
            '④   現行の終了と次行の開始の間　strEND_TARGET_CRNT　＜　strSTART_NEWRNG_CRNT　＜ strSTART_TARGET_NEXT
            '　1行下に挿入
            '　次行の開始にstrSTART_NEWRNG_CRNTセット
            '　次行の終了に(strSTART_TARGET_NEXT - 1)
            If (strSTART_NEWRNG_CRNT > strEND_TARGET_CRNT) And (strSTART_NEWRNG_CRNT < strSTART_TARGET_NEXT) Then
                sOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　次行の開始にstrSTART_NEWRNG_CRNTセット
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strSTART_NEWRNG_CRNT
                '　次行の終了に(strSTART_TARGET_NEXT - 1)
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET + 1)).Value = Format(CLng(strSTART_TARGET_NEXT) - 1, "000000")
                ' 処理終わり
                GoTo TO_END1
            End If

TO_END1:

            '■■■■終了（END）番号チェック■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
            '①現行開始と一致
            '　1行下に挿入
            '　現行終了にstrEND_NEWRNG_CRNTセット
            '　次行開始に(strEND_NEWRNG_CRNT + 1)
            If (strEND_NEWRNG_CRNT = strSTART_TARGET_CRNT) Then
                eOK = True
                ' ただし現行開始(TARGET)が現行開始(NEWRNG)を超えていたら分割不要
                If (strSTART_NEWRNG_CRNT < strSTART_TARGET_CRNT) Then
                    ' 処理終わり
                    GoTo CONT_FOR1
                End If
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　現行終了にstrEND_NEWRNG_CRNTセット
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = strEND_NEWRNG_CRNT
                '　次行開始に(strEND_NEWRNG_CRNT + 1)
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If
            '②現行終了と一致
            '　1行下に挿入
            '　次行の開始にstrEND_NEWRNG_CRNTセット
            '　現行の終了に(strEND_NEWRNG_CRNT - 1)
            If (strEND_NEWRNG_CRNT = strEND_TARGET_CRNT) Then
                eOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　次行の開始にstrEND_NEWRNG_CRNTセット
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strEND_NEWRNG_CRNT
                '　現行の終了に(strEND_NEWRNG_CRNT - 1)
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = Format(CLng(strEND_NEWRNG_CRNT) - 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If
            '③現行開始と現行終了の間
            '　1行下に挿入
            '　現行終了にstrEND_NEWRNG_CRNTセット
            '　次行開始に(strEND_NEWRNG_CRNT + 1)
            If (strEND_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strEND_TARGET_CRNT) Then
                eOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　現行終了にstrEND_NEWRNG_CRNTセット
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = strEND_NEWRNG_CRNT
                '　次行開始に(strEND_NEWRNG_CRNT + 1)
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If

            ' ④現行終了と次行開始の間
            '　1行下に挿入
            '　現行終了にstrEND_NEWRNG_CRNTセット
            '　次行開始に(strEND_NEWRNG_CRNT + 1)
            If (strEND_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strSTART_TARGET_NEXT) Then
                eOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　現行終了にstrEND_NEWRNG_CRNTセット
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = strEND_NEWRNG_CRNT
                '　次行開始に(strEND_NEWRNG_CRNT + 1)
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If
CONT_FOR2:
        Next idx_TARGET

        '   5   上記以外（値が見つからない）  ■先頭挿入    S0にSセット E0にSX-1
        If sOK = False Then
            wsTARGET.Activate
            wsTARGET.Rows("1:1").Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Selection.Interior.Color = vbRed
            wsTARGET.Range(COL_END_TARGET & (1)).Value = Format(CLng(wsTARGET.Range(COL_START_TARGET & (2)).Text) - 1, "000000")
            wsTARGET.Range(COL_START_TARGET & (1)).Value = strSTART_NEWRNG_CRNT
        End If

        '   5   上記以外（値が見つからない   ■最下挿入    EXにEセット SXにEX+1
        '
        If eOK = False Then
            wsTARGET.Activate
            Dim rowLast As Long
            rowLast = wsTARGET.UsedRange.Row
            wsTARGET.Rows(rowLast & ":" & rowLast).Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Selection.Interior.Color = vbRed
            wsTARGET.Range(COL_END_TARGET & (rowLast + 1)).Value = strEND_NEWRNG_CRNT
            wsTARGET.Range(COL_START_TARGET & (rowLast + 1)).Value = Format(CLng(wsTARGET.Range(COL_END_TARGET & (rowLast - 1)).Text) + 1, "000000")
        End If

CONT_FOR1:
    Next idx_NEWRNG

End Sub
はじめての簡単 Excel VBA［決定版］　（Windows8/Excel2013完全対応）【電子書籍】[ 金城俊哉 ]
[VBA,VB.NET,C#,PHP]プログラムTips集

[VBA,VB.NET,C#,PHP]プログラムのちょっとしたテクニック

【VBA】データを分割（統合）ための極意【パターン化によるデータ分割】
