|
こんなのでは?
C列、G列を作業列に使用します
Option Explicit
Public Sub Sample()
Dim i As Long
Dim j As Long
Dim lngRows1 As Long
Dim lngRows2 As Long
Dim vntData1 As Variant
Dim vntData2 As Variant
Dim strProm As String
'画面更新を停止
Application.ScreenUpdating = False
With ActiveSheet
'A列グループ、E列グループを先頭列で整列
DataSort .Columns("A:B"), Range("A1")
DataSort .Columns("E:F"), Range("E1")
'A列グループ、E列グループの最終行を取得
lngRows1 = .Cells(Rows.Count, "A").End(xlUp).Row
lngRows2 = .Cells(Rows.Count, "E").End(xlUp).Row
'A列グループのA列をC列にCopy、E列グループのE列をG列にCopyします
.Columns("A").Copy Destination:=.Columns("C")
.Columns("E").Copy Destination:=.Columns("G")
'A列、E列を比較
i = 1: j = 1
vntData1 = .Cells(i, "A").Value
vntData2 = .Cells(j, "E").Value
'A列、E列が共に最終行に成るまで繰り返し
Do Until IsEmpty(vntData1) And IsEmpty(vntData2)
'A列が最終行に達したら
If IsEmpty(vntData1) Then
lngRows1 = lngRows1 + 1
.Cells(lngRows1, "C").Value = vntData2
j = j + 1
'E列が最終行に達したら
ElseIf IsEmpty(vntData2) Then
lngRows2 = lngRows2 + 1
.Cells(lngRows2, "G").Value = vntData1
i = i + 1
Else
Select Case vntData1
Case Is = vntData2 'A、E列の値が同じなら何もしない
i = i + 1
j = j + 1
Case Is < vntData2 'A列だけに在る値
'G列最終行にA列の値を追加
lngRows2 = lngRows2 + 1
.Cells(lngRows2, "G").Value = vntData1
i = i + 1
Case Else 'E列だけに在る値
'C列最終行にE列の値を追加
lngRows1 = lngRows1 + 1
.Cells(lngRows1, "C").Value = vntData2
j = j + 1
End Select
End If
vntData1 = .Cells(i, "A").Value
vntData2 = .Cells(j, "E").Value
Loop
'A列グループをC列で、E列グループをG列で整列
DataSort .Columns("A:C"), Range("C1")
DataSort .Columns("E:G"), Range("G1")
'C列、G列を消去
.Columns("C").ClearContents
.Columns("G").ClearContents
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
MsgBox strProm, vbInformation
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngSortOrder As Long = xlAscending, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=lngSortOrder, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
|
|