Posted at

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

More than 3 years have passed since last update.

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

マクロって難しいですね。


Module1.xlsm

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



Module2.xlsm

' シートがあるかどうかを確認

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