| |
Sheet1､Sheet2をソートしても善いならこんなやり方も在ります
やはり1行づつ比較している事には変わり無いんだけどね？
データの例が少ないので検証不足で上手く行かなかったらゴメン
また、オートフィルタは使っていません
ただ、以下のことが気に成ります
>またオートフィルターで項目１が「未定」のものを選びますが、
>その際にシート2のデータと照らし合わせて､以前と変わらない
>データはそのままに､シート2にないデータは削除､新規のデータ
>のみを貼り付けたいのですが｡この場合､次のようにしたいのです｡
「シート2にないデータは削除」てシート1から？
尚、ここで使っている方法を先に説明しておきます
実際にトランプ等で試して見ると解りやすいと思います
ここでは､トランプを例に取って説明します
なんでも善いのですが､例えばハートの山とクラブの山を使います
1 ､先ず､ハートの山､クラブの山から適当に何枚かづつ引き抜きます
2 ､次に､夫々の山を､下に行くほど数が大きく成る様に積み上げます
要は､夫々の山を昇順にソートする
3 ､ここからLoopに入ります
4 ､夫々の山の上から1枚ずつ引きます
5 ､引いた札の値が､例えばハートの方がクラブより小さい場合
この値はハートの山固有の値と成ります (ハートの山にだけ有る値の札)
理由は､両方の山共ソートして有るので､クラブの山には
この値未満の値が無い為､固有と決定できます
6 ､引いたハートの札を棄て､また､ハートの山の上から1枚引きます
7 ､此れを､先のクラブの札と値を比較します
8 ､こんどは､クラブの札の値が､ハートの札の値より小さく成りました
9 ､5と同様の理由でこれはクラブの山固有の値の札と成ります
10 ､クラブの札を棄て､クラブの山の上から1枚引き､先のハートの札の値と比較します
11 ､今度は､両方の値が同じと成りました
12 ､当然､これは共有の値と成ります
13 ､両方の札を棄て､両方の山の上から1枚づつ引き比較します
14 ､此れを､どちらかの山が無くなるまで繰り返します (Loopを抜ける)
15 ､どちらかの山に札が残った場合､其の札はその山固有の物と成ります
上記の考え方でコードを作ると以下の要に成ります
尚､ソートにExcelの並べ替えを使用する場合､比較順序がTextCompareの扱いに成るので
モジュールの先頭で「Option Compare Text」をして置いて下さい
以下を標準モジュールに記述してください
Option Explicit
Option Compare Text
Public Sub DataMatch()
Const strExclusion As String = "決定"
Dim i As Long
Dim rngATop As Range
Dim lngAEnd As Long
Dim lngAPos As Long
Dim vntAData As Variant
Dim rngBTop As Range
Dim lngBEnd As Long
Dim lngBPos As Long
Dim vntBData As Variant
Dim lngWrite As Long
Dim lngCol As Long
'画面の更新の停止
Application.ScreenUpdating = False
'Sheet1の左上（番号）のセルを設定
Set rngATop = Worksheets("Sheet1").Cells(1, 1)
'Sheet1をソートして、列数、最終行を取得
ListSorting rngATop, 1, lngAEnd, lngCol
'Sheet1の読み込みの先頭行を設定
lngAPos = rngATop.Row
'Sheet2の左上（番号）のセルを設定
Set rngBTop = Worksheets("Sheet2").Cells(1, 1)
'Sheet2をソートして、列数、最終行を取得
ListSorting rngBTop, 1, lngBEnd
'Sheet2の読み込みの先頭行を設定
lngBPos = rngBTop.Row
'出力行初期値を設定
lngWrite = lngBPos + lngBEnd
'Sheet1、Sheet2のデータ先頭行の先読み
vntAData = DataRead(rngATop, lngAPos, lngCol)
vntBData = DataRead(rngBTop, lngBPos, lngCol)
'Sheet1、Sheet2どちらかが無くなるまで繰り返し
Do Until lngAPos > lngAEnd Or lngBPos > lngBEnd
If vntAData(1, 4) = strExclusion Then
lngAPos = lngAPos + 1
vntAData = DataRead(rngATop, lngAPos, lngCol)
Else
Select Case vntAData(1, 1)
Case Is = vntBData(1, 1) 'Key項目がMatchした場合
'データに変更が有った場合
If Not DataCheck(vntAData, vntBData) Then
'Sheet1の行をSheet2の行に置き換え
DataOut rngATop, lngAPos, _
lngCol, rngBTop, lngBPos
End If
'Sheet1、Sheet2の読み込み位置を更新
lngAPos = lngAPos + 1
lngBPos = lngBPos + 1
'Sheet1、Sheet2の次行の読み込み
vntAData = DataRead(rngATop, lngAPos, lngCol)
vntBData = DataRead(rngBTop, lngBPos, lngCol)
Case Is < vntBData(1, 1) 'Sheet1の固有値の場合
'Sheet1の行をSheet2の最終行に追加
DataOut rngATop, lngAPos, _
lngCol, rngBTop, lngWrite
'Sheet1の読み込み、出力行位置を更新
lngAPos = lngAPos + 1
lngWrite = lngWrite + 1
'Sheet1の次行の読み込み
vntAData = DataRead(rngATop, lngAPos, lngCol)
Case Is > vntBData(1, 1) 'Sheet2の固有値の場合
'Sheet2の行を削除
rngBTop.Offset(lngBPos).EntireRow.Delete
'行削除の為、最終行位置、出力行位置を更新
lngBEnd = lngBEnd - 1
lngWrite = lngWrite - 1
'Sheet2の次行の読み込み
vntBData = DataRead(rngBTop, lngBPos, lngCol)
End Select
End If
Loop
'Sheet1に行が残っている場合の処理
For i = lngAPos To lngAEnd
vntAData = DataRead(rngATop, i, lngCol)
If vntAData(1, 4) <> strExclusion Then
'Sheet1の行をSheet2の最終行に追加
DataOut rngATop, i, lngCol, rngBTop, lngWrite
'出力行位置を更新
lngWrite = lngWrite + 1
End If
Next i
'Sheet2に行が残っている場合の処理
For i = lngBEnd To lngBPos Step -1
'Sheet2の行を削除
rngBTop.Offset(i).EntireRow.Delete
Next i
Set rngATop = Nothing
Set rngBTop = Nothing
Application.ScreenUpdating = True
Beep
MsgBox "処理が終了しました"
End Sub
Private Function DataRead(rngRead As Range, _
lngPos As Long, _
lngCol As Long) As Variant
' データの読み込み
DataRead _
= rngRead.Offset(lngPos).Resize(, lngCol).Value
End Function
Private Sub DataOut(rngCopy As Range, _
lngCopyRow As Long, _
lngColCount As Long, _
rngDestination As Range, _
lngWrite As Long)
' 転記先えの出力
rngCopy.Offset(lngCopyRow).Resize(, lngColCount).Copy _
Destination:=rngDestination.Offset(lngWrite)
End Sub
Private Sub ListSorting(rngListTop As Range, _
lngKey As Long, _
lngRowEnd As Long, _
Optional lngColCount As Long)
' ListのKey項目に就いての並べ替えと、データ取得
Dim rngScope As Range
Set rngScope = rngListTop.CurrentRegion
With rngScope
.Sort Key1:=.Item(1, lngKey), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
lngRowEnd = .Rows.Count - 1
lngColCount = .Columns.Count
End With
Set rngScope = Nothing
End Sub
Private Function DataCheck(vntListA As Variant, _
vntListB As Variant) As Boolean
' 行の比較
Dim i As Long
DataCheck = True
For i = 1 To UBound(vntListA, 2)
If vntListA(1, i) <> vntListB(1, i) Then
DataCheck = False
Exit Function
End If
Next i
End Function
|
|
Hirofumi
- 04/5/2(日) 19:19 -
