| |
'"対象マスター"のA列と"発注商品"のA列を比較して、同じ物が有ったら
'"発注商品"の其の行を削除すると言う事で善いのかな？
Option Explicit
Public Sub DataMatch()
' 検索条件に合ったものを行ごと削除
'"対象マスター"のデータ列数（A列〜J列の10列）
Const clngColumns1 As Long = 10
'"対象マスター"の比較Key列位置（基準からのA列「Ｊコード」列Offset値）
Const clngKeys1 As Long = 0
'"発注商品"のデータ列数（A列〜C列の3列）
Const clngColumns2 As Long = 3
'"発注商品"の比較Key列位置（基準からのA列「Ｊコード」の列Offset値）
Const clngKeys2 As Long = 0
'"発注商品"の最終整列Key列(C列)
Const clngSort As Long = 2
Dim i As Long
Dim rngList1 As Range
Dim lngEnd1 As Long
Dim vntData1 As Variant
Dim lngRow1 As Long
Dim rngList2 As Range
Dim lngEnd2 As Long
Dim vntData2 As Variant
Dim lngRow2 As Long
Dim lngDelete() As Long
Dim lngCount As Long
Dim strProm As String
'"対象マスター"データのA1を基準とします（列見出しのセル位置）
Set rngList1 = Worksheets("対象マスター").Cells(1, "C")
'"発注商品"データのA1を基準とする（列見出しのセル位置）
Set rngList2 = Worksheets("発注商品").Cells(1, "A")
'画面更新を停止
' Application.ScreenUpdating = False
'"対象マスター"データの基準に就いて基礎データの取得
If Not GetBasicData(rngList1, lngEnd1, clngColumns1, clngKeys1, vntData1) Then
strProm = rngList1.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'"発注商品"データの基準に就いて基礎データの取得
If Not GetBasicData(rngList2, lngEnd2, clngColumns2, clngKeys2, vntData2) Then
strProm = rngList2.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'削除Flagの配列を確保
ReDim lngDelete(1 To lngEnd2, 1 To 1)
'"対象マスター"の比較位置
lngRow1 = 1
'"発注商品"の比較位置
lngRow2 = 1
'"対象マスター"若しくは、"発注商品"が最終行に達するまで繰り返し
Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
'比較結果に就いて
Select Case vntData1(lngRow1, 1)
Case Is = vntData2(lngRow2, 1) 'Matchiした場合
'削除Flagを立てる
lngDelete(lngRow2, 1) = 1
'削除数をカウント
lngCount = lngCount + 1
'両データの比較位置の更新
lngRow1 = lngRow1 + 1
lngRow2 = lngRow2 + 1
Case Is > vntData2(lngRow2, 1) '"発注商品"固有値の場合
'"発注商品"の比較位置を更新
lngRow2 = lngRow2 + 1
Case Is < vntData2(lngRow2, 1) '"対象マスター"固有値の場合
'"対象マスター"の比較位置を更新
lngRow1 = lngRow1 + 1
End Select
Loop
'"対象マスター"データの復旧
With rngList1
'元データ順位を復帰
.Offset(1).Resize(lngEnd1, clngColumns1 + 1).Sort _
Key1:=.Offset(1, clngColumns1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'復帰用Key列を削除
.Offset(, clngColumns1).EntireColumn.Delete
End With
With rngList2
'削除Flagの配列を出力
.Offset(1, clngColumns2 + 1) _
.Resize(lngEnd2).Value = lngDelete
'削除Flag列順のC列順で整列
.Offset(1).Resize(lngEnd2, clngColumns2 + 2).Sort _
Key1:=.Offset(1, clngColumns2 + 1), Order1:=xlAscending, _
Key2:=.Offset(1, clngSort), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'削除データが有るなら
If lngCount > 0 Then
'行削除
.Offset(lngEnd2 - lngCount + 1) _
.Resize(lngCount).EntireRow.Delete
strProm = lngCount & "件の削除が完了しました"
Else
strProm = "削除行が有りません"
End If
'復帰用Key列を削除
.Offset(, clngColumns2).Resize(, 2).EntireColumn.Delete
End With
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetBasicData(rngList As Range, _
lngRows As Long, _
lngColumns As Long, _
lngKeys As Long, _
vntData As Variant) As Boolean
Dim i As Long
Dim lngNumb() As Long
'基準に就いて
With rngList
'行数を取得
lngRows = .Offset(65536 - .Row, lngKeys).End(xlUp).Row - .Row
'データが無ければFunctionを抜ける(戻り値=False)
If lngRows < 0 Then
Exit Function
End If
'復帰用整列Keyを作成
ReDim lngNumb(1 To lngRows, 1 To 1)
For i = 1 To lngRows
lngNumb(i, 1) = i
Next i
'復帰用Keyの出力列を挿入
.Offset(1, lngColumns).EntireColumn.Insert
'復帰用Keyの出力
.Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
'データをlngKeys列で整列
.Offset(1).Resize(lngRows, lngColumns + 1).Sort _
Key1:=.Offset(1, lngKeys), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'データを配列に取得
vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
End With
GetBasicData = True
End Function
|
|
Hirofumi
- 06/6/24(土) 14:14 -
