【エクセルVBA】範囲（枠）を別範囲（枠）で分割するアルゴリズム
Public sOK As Boolean Public eOK As Boolean ' 分割する側 Const COL_START_DATA = "A" Const COL_END_DATA = "B" ' 分割される側 Const COL_START_ORG = "B" Const COL_END_ORG = "C" Public Sub SplitRowData() ' 分割される側のシート Dim wsORG As Worksheet ' 分割する側のシート Dim wsDATA As Worksheet ' 分割される側のインデックス Dim iOrg As Long '分割する側のインデックス Dim iData As Long 'ワークシートの設定 Set wsORG = ThisWorkbook.Sheets("ORIGINAL") Set wsDATA = ThisWorkbook.Sheets("NDATA") ' 分割する側のデータ側でループ For iData = 1 To 10000 DoEvents ' フラグ初期化 sOK = False eOK = False 'カレントデータを保存 Dim sData As String Dim eData As String '分割する側のデータを取得（カレント） sData = wsDATA.Range(COL_START_DATA & iData).Text eData = wsDATA.Range(COL_END_DATA & iData).Text '分割する側が空白になったら終了 If eData = "" Or sData = "" Then Exit Sub End If ' オリジナルデータ側でループ For iOrg = 1 To 10000 DoEvents '一個前のデータ Dim sOrg_PREV As String Dim eOrg_PREV As String 'カレントデータ Dim sOrg As String Dim eOrg As String '次のデータ Dim sOrg_NEXT As String Dim eOrg_NEXT As String '一個前のデータを取得 If iOrg > 1 Then sOrg_PREV = wsORG.Range(COL_START_ORG & (iOrg - 1)).Text eOrg_PREV = wsORG.Range(COL_END_ORG & (iOrg - 1)).Text End If 'カレントデータ取得 sOrg = wsORG.Range(COL_START_ORG & iOrg).Text eOrg = wsORG.Range(COL_END_ORG & iOrg).Text '次の行のデータ sOrg_NEXT = wsORG.Range(COL_START_ORG & (iOrg + 1)).Text eOrg_NEXT = wsORG.Range(COL_END_ORG & (iOrg + 1)).Text '空白に達したらループを抜ける If sOrg = "" Or sOrg = "" Then GoTo CONT_FOR1: End If ' ' まず全体のチェックから始める ' ① 範囲が完全一致 If (sData = sOrg) And (eData = eOrg) Then sOK = True eOK = True GoTo CONT_FOR1 End If ' ② 範囲が完全に含まれる 挿入×2 S2にS E2にE E1にS-1 S3にE+1 If (sData > sOrg) And (eData < eOrg) Then sOK = True eOK = True ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' S2にS wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = sData ' E2にE wsORG.Range(COL_END_ORG & (iOrg + 1)).Value = eData ' E1にS-1 wsORG.Range(COL_END_ORG & (iOrg)).Value = Format(CLng(sData) - 1, "000000") ' S3にE+1 wsORG.Range(COL_START_ORG & (iOrg + 2)).Value = Format(CLng(eData) + 1, "000000") ' 処理終わり GoTo CONT_FOR1 End If ' ③ 行を跨いで完全に含まれる If (sData > eOrg) And (eData < sOrg_NEXT) Then sOK = True eOK = True ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' S2にS wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = sData ' E2にE wsORG.Range(COL_END_ORG & (iOrg + 1)).Value = eData ' 処理終わり GoTo CONT_FOR1 End If ' '■■■■開始（START）番号チェック■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■ '①sDataとsOrgが一致したら、 ' 1行下に挿入 ' 現行の終了にsDataに設定 ' 次行の開始に(sData + 1)を設定 If (sData = sOrg) Then sOK = True ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' E1にSセット wsORG.Range(COL_END_ORG & (iOrg)).Value = sData ' S2にS+1 wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = Format(CLng(sData) + 1, "000000") ' 処理終わり GoTo TO_END1 End If '②sDataとeOrgが一致 ' 1行下に挿入 ' 次行の開始にsDataセット ' 現業の終了に(sData - 1)セット If (sData = eOrg) Then sOK = True ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' S2にSセット wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = sData ' E1にS-1 wsORG.Range(COL_END_ORG & (iOrg)).Value = Format(CLng(sData) - 1, "000000") ' 処理終わり GoTo TO_END1 End If '③開始と終了に挟まれる場合 sOrg ＜ sData ＜ eOrg ' 1行下に挿入 ' 次行の開始にsDataセット ' 現業の終了に(sData - 1) If (sData > sOrg) And (sData < eOrg) Then sOK = True ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' S2にSセット wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = sData ' E1にS-1 wsORG.Range(COL_END_ORG & (iOrg)).Value = Format(CLng(sData) - 1, "000000") ' 処理終わり GoTo TO_END1 End If '④ 現行の終了と次行の開始の間 eOrg ＜ sData ＜ sOrg_NEXT ' 1行下に挿入 ' 次行の開始にsDataセット ' 次行の終了に(sData_NEX - 1) If (sData > eOrg) And (sData < sOrg_NEXT) Then sOK = True ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' S2にSセット wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = sData ' E2にS3-1 wsORG.Range(COL_END_ORG & (iOrg + 1)).Value = Format(CLng(sData_NEX) - 1, "000000") ' 処理終わり GoTo TO_END1 End If TO_END1: '■■■■終了（END）番号チェック■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■ '①現行開始と一致 ' 1行下に挿入 ' 現行終了にeDataセット ' 次行開始に(eData + 1) If (eData = sOrg) Then eOK = True ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' E1にEセット wsORG.Range(COL_END_ORG & (iOrg)).Value = eData ' S2にE+1 wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = Format(CLng(eData) + 1, "000000") ' 処理終わり GoTo CONT_FOR1 End If '②現行終了と一致 ' 1行下に挿入 ' 次行の開始にeDataセット ' 現行の終了に(eData - 1) If (eData = eOrg) Then eOK = True ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' S2にEセット wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = eData ' E1にE-1 wsORG.Range(COL_END_ORG & (iOrg)).Value = Format(CLng(eData) - 1, "000000") ' 処理終わり GoTo CONT_FOR1 End If '③現行開始と現行終了の間 ' 1行下に挿入 ' 現行終了にeDataセット ' 次行開始に(eData + 1) If (eData > sOrg) And (eData < eOrg) Then eOK = True ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' E1にEセット wsORG.Range(COL_END_ORG & (iOrg)).Value = eData ' S2にE+1 wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = Format(CLng(eData) + 1, "000000") ' 処理終わり GoTo CONT_FOR1 End If ' ④現行終了と次行開始の間 ' 1行下に挿入 ' 現行終了にeDataセット ' 次行開始に(eData + 1) If (eData > sOrg) And (eData < sOrg_NEXT) Then eOK = True ' 挿入 wsORG.Activate wsORG.Rows(iOrg & ":" & iOrg).Select Selection.Copy Selection.Insert Shift:=xlDown Selection.Interior.Color = vbRed ' E1にEセット wsORG.Range(COL_END_ORG & (iOrg)).Value = eData ' S2にE+1 wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = Format(CLng(eData) + 1, "000000") ' 処理終わり GoTo CONT_FOR1 End If CONT_FOR2: Next iOrg ' 5 上記以外（値が見つからない） ■先頭挿入 S0にSセット E0にSX-1 If sOK = False Then wsORG.Activate wsORG.Rows("1:1").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Selection.Interior.Color = vbRed wsORG.Range(COL_END_ORG & (1)).Value = Format(CLng(wsORG.Range(COL_START_ORG & (2)).Text) - 1, "000000") wsORG.Range(COL_START_ORG & (1)).Value = sData End If ' 5 上記以外（値が見つからない ■最下挿入 EXにEセット SXにEX+1 ' If eOK = False Then wsORG.Activate Dim rowLast As Long rowLast = wsORG.UsedRange.Row wsORG.Rows(rowLast & ":" & rowLast).Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Selection.Interior.Color = vbRed wsORG.Range(COL_END_ORG & (rowLast + 1)).Value = eData wsORG.Range(COL_START_ORG & (rowLast + 1)).Value = Format(CLng(wsORG.Range(COL_END_ORG & (rowLast - 1)).Text) + 1, "000000") End If CONT_FOR1: Next iData End Sub
Windows 10 Home 64bit Jpn DSP DVD 【LANボード セット限定】 JP9PNC
- ジャンル: パソコン・周辺機器 > ソフトウェア > OS（オペレーティングシステム） > Windows
- ショップ: パソコンパーツのアプライド
- 価格: 13,980円
