ExcelVBA 配列を使用した高速処理② ２行にまたがるレコードを１行にまとめる

■WEB画面の表をスクレイピングした際などに表の項目のセルが分割されていたり１レコードが２行にまたがるなどしてキレイにテーブルが取得できない場合などに２行に割れたレコードを１行に編集する。

■サンプルコード
configモジュール

Option Explicit
Public Const intDpartmentCol As Integer = 1
Public Const intGroupCol As Integer = 1
Public Const intPlaceCol As Integer = 2
Public Const intStartDayCol As Integer = 3
Public Const intHotelChargesCol As Integer = 3
Public Const intEndDayCol As Integer = 4
Public Const intPeopleNumCol As Integer = 4
Public Const intTermCol As Integer = 5

呼び出し元モジュール

Sub editfile()
    Dim strFilePath As String
    Dim strShName1 As String
    Dim strShName2 As String
    Dim strResult As String       
    strFilePath = "C:\Users\yamada\OneDrive\デスクトップ\ExcelVBAプロジェクト\2行→１行結合テスト\はてな用\テストデータ.xlsx"
    strShName1 = "Sheet1"
    strShName2 = "Sheet2"    
    strResult = fncMargeRows(strFilePath, strShName1, strShName2)    
    MsgBox strResult    
End Sub

Functionモジュール

Function fncMargeRows(strPath As String, strSheetName1 As String, strSheetName2 As String) As String
'--------------------------------------------------
'機能：１レコードが２行にまたがってしまっている状態を１行にまとめる
'引数1：対象ファイルパス
'引数2：対象シート名
'引数3：編集後レコードの記載先シート名
'--------------------------------------------------
    Dim temp As Variant
    Dim MargeTable(1 To 500, 1 To 8) As Variant
    Dim PasteRange As Variant
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim lngLastRow As Integer
    Dim i As Long
    Dim k As Long
    Set wb = Workbooks.Open(strPath)
    Set sh = wb.Sheets(strSheetName1)    
    lngLastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
    temp = sh.Range(Cells(2, 1), Cells(lngLastRow, 5))    
    k = 1
    For i = 1 To lngLastRow - 1
            If i Mod 2 = 1 Then
                MargeTable(k, 1) = temp(i, intDpartmentCol)
                MargeTable(k, 3) = temp(i, intPlaceCol)
                MargeTable(k, 6) = temp(i, intStartDayCol)
                MargeTable(k, 7) = temp(i, intEndDayCol)
                MargeTable(k, 8) = temp(i, intTermCol)
            Else
                MargeTable(k, 2) = temp(i, intGroupCol)
                MargeTable(k, 4) = temp(i, intHotelChargesCol)
                MargeTable(k, 5) = temp(i, intPeopleNumCol)
                k = k + 1
            End If
    Next i    
    Set sh = Nothing    
    wb.Worksheets.Add(After:=Worksheets(1)).Name = strSheetName2    
    Set sh = wb.Worksheets(strSheetName2)    
    With sh
        .Cells(1, 1) = "部署"
        .Cells(1, 2) = "グループ"
        .Cells(1, 3) = "出張先"
        .Cells(1, 4) = "宿泊費の有無"
        .Cells(1, 5) = "人数"
        .Cells(1, 6) = "開始日"
        .Cells(1, 7) = "終了日"
        .Cells(1, 8) = "清算期間"
        .Range(Cells(2, 1), Cells(500, 8)) = MargeTable    
    End With    
    wb.Save    
    fncMargeRows = "OK"    
    wb.Close True
    Set wb = Nothing
End Function