２つのシートを並べ替えて結合する処理

※昔書いた記事を某所から移行。

---

先日マクロで２つのファイルを結合して並べ替える処理を作ったので備忘録的に。 マクロって難しいですね。

Public Const MITSUMORI As String = "見積もり"
Public Const SHIRE As String = "仕入れ先"
Public Const KATABAN As String = "型番"
Public Const KINGAKU As String = "金額"

Sub Main()
    ' シートの用意
    Call ClearWorkSheets
    Call CreateWorkSheets
    Call CopyToWorkbook(SHIRE)
    Call CopyToWorkbook(MITSUMORI)
    
    ' ソート
    Call KatabanSort(SHIRE)
    Call KatabanSort(MITSUMORI)
    
    ' マージ処理
    Call KingakuTeknki
    
    MsgBox "完了！"
End Sub


' 前回読み込んだシートがあった場合に削除
Private Sub ClearWorkSheets()
    Application.DisplayAlerts = False
    With ThisWorkbook
        If SheetDetect(MITSUMORI) Then
            .Worksheets(MITSUMORI).Delete
        End If
        If SheetDetect(SHIRE) Then
            .Worksheets(SHIRE).Delete
        End If
    End With
    Application.DisplayAlerts = True
End Sub

' 作業用のシートを作成
Private Sub CreateWorkSheets()
    ' アクティブなシートを記憶
    Dim OldSheet As Worksheet
    Set OldSheet = ActiveSheet
    
    ' 見積もり用のシートを作成
    Dim NewMitsumoriSheet As Worksheet
    Set NewMitsumoriSheet = Worksheets.Add(After:=Worksheets(Worksheets.count))
    NewMitsumoriSheet.Name = MITSUMORI
    
    ' 仕入れ先用のシートを作成
    Dim NewShireSheet As Worksheet
    Set NewShireSheet = Worksheets.Add(After:=Worksheets(Worksheets.count))
    NewShireSheet.Name = SHIRE
    
    OldSheet.Activate
End Sub

' ファイルを開いてシートをコピー
Private Sub CopyToWorkbook(Target As String)
    Dim OldWorksheet As Workbook
    Dim TargetSheet As Worksheet
    Dim OpenFileName As String
    
    ' コピー先のワークシートを保持
    Set OldWorksheet = ThisWorkbook
    
    ' ファイルを開く
    MsgBox (Target & "用のファイルを選択してください")
    OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xlsx?")
    Workbooks.Open OpenFileName, ReadOnly:=True
    
    ' シートにコピー
    Set TargetSheet = ActiveWorkbook.Worksheets(1)
    TargetSheet.Cells.Copy OldWorksheet.Worksheets(Target).Range("A1")
    
    ActiveWorkbook.Close
End Sub


' シートを型番でソート
Private Sub KatabanSort(SheetName As String)
    Dim ActivateSheet As Worksheet
    Dim MaxRow As Long
    Dim MaxCol As Long
    Dim KatabanCol As Long
    
    ' 対象のシートの縦横サイズを獲得
    MaxRow = RowEnd(SheetName)
    MaxCol = RowEnd(SheetName)
    ' 型番の行を取得
    KatabanCol = getKataban(SheetName)
    
    If SheetName = SHIRE Then
        Dim KingakuCol As Long
        KingakuCol = getKingaku(SheetName)
        Call DeleteDuplicate(KatabanCol, KingakuCol, MaxRow)
    End If
    
    Set ActivateSheet = ActiveWorkbook.Worksheets(SheetName)
    ActivateSheet.Activate
    'ソートの実行
    Range("A1", Cells(MaxRow, MaxCol)).Sort (Cells(1, KatabanCol)), Header:=xlYes
End Sub

' 型番を比較して金額を転記
Private Sub KingakuTeknki()
    ' 型番の行を取得
    KatabanCol = getKataban(MITSUMORI)
    
    ' 転記先（見積もりシート）をアクティブにする
    Dim ActivateSheet As Worksheet
    Set ActivateSheet = ActiveWorkbook.Worksheets(MITSUMORI)
    ActivateSheet.Activate

    ' 型番の右隣の列に金額欄を追加
    Columns(KatabanCol + 1).Insert
    Cells(1, (KatabanCol + 1)) = KINGAKU
    
    Dim i As Long
    Dim j As Long
    Dim MitsumoriCount As Long
    Dim ShireCount As Long
    
    MitsumoriCount = RowEnd(MITSUMORI)
    ShireCount = RowEnd(SHIRE)
    
    Dim MitsumoriKataban As Long
    Dim ShireKataban As Long
    Dim MitsumoriKingaku As Long
    Dim ShireKingaku As Long
    
    MistumoriKataban = getKataban(MITSUMORI)
    ShireKataban = getKataban(SHIRE)
    MitsumoriKingaku = getKingaku(MITSUMORI)
    ShireKingaku = getKingaku(SHIRE)
    
    ' 見積もりシートと仕入れシートを比較し、一致するモノがあれば転記
    ' 高速化のためにソート済みであることを利用する
    For i = 2 To MitsumoriCount
        For j = 2 To ShireCount
            If Worksheets(MITSUMORI).Cells(i, MistumoriKataban) = _
                Worksheets(SHIRE).Cells(j, ShireKataban) Then
                ' 転記
                Worksheets(MITSUMORI).Cells(i, MitsumoriKingaku) = _
                    Worksheets(SHIRE).Cells(j, ShireKingaku)
                Exit For
            ElseIf Worksheets(MITSUMORI).Cells(i, MistumoriKataban) < _
                    Worksheets(SHIRE).Cells(j, ShireKataban) Then
                ' 次の行の確認へ
                j = j - 1
                Exit For
            End If
        Next j
    Next i
End Sub

' シートがあるかどうかを確認
Public Function SheetDetect(SName As String) As Boolean
    Dim sheet As Worksheet
    For Each sheet In ThisWorkbook.Worksheets
        If sheet.Name = SName Then
            SheetDetect = True
            Exit Function
        End If
    Next
End Function

' 1つの型番に複数の金額があったときに、高い方を残す
Public Sub DeleteDuplicate(KatabanCol As Long, KingakuCol As Long, CountEnd As Long)
    Dim i As Long
    Dim j As Long
    Dim count As Long
    
    With ActiveWorkbook.Worksheets(SHIRE)
        count = CountEnd
        
        For i = 2 To count
            For j = i + 1 To count
                If .Cells(i, KatabanCol) = .Cells(j, KatabanCol) Then
                    If .Cells(i, KingakuCol) > .Cells(j, KingakuCol) Then
                        .Rows(j).Delete
                    Else
                        .Rows(i).Delete
                    End If
                    j = j - 1
                    count = count - 1
                End If
            Next j
        Next i
    End With
    
End Sub

' シートの最終行を取得
Public Function RowEnd(SheetName As String) As Long
    RowEnd = ActiveWorkbook.Worksheets(SheetName).Range("A1").SpecialCells(xlLastCell).Row
End Function

' シートの最終列を取得
Public Function ColEnd(SheetName As String) As Long
    ColEnd = ActiveWorkbook.Worksheets(SheetName).Range("A1").SpecialCells(xlLastCell).Column
End Function

Public Function getKataban(SheetName) As Long
    getKataban = ActiveWorkbook.Worksheets(SheetName).Cells.Find(KATABAN).Column
End Function

Public Function getKingaku(SheetName) As Long
    getKingaku = ActiveWorkbook.Worksheets(SheetName).Cells.Find(KINGAKU).Column
End Function