| |
▼Hirofumi さん：
ありがとうございます。
私にはかなり難しすぎました。
解説も丁寧に書いてくださっているので
調べて理解していきます。
>こんな事すると出来るかも？
>"旧.xlsx"、"新.xlsx"は開いてている物とします
>出力はマクロの或るBookのSheet3とします
>
>Option Explicit
>Option Compare Text
>
>Public Sub DataMatch2()
>
>' 固有データのチェック
>
> '"旧"のデータ列数（C列〜D列）
> Const clngColumns1 As Long = 2
> '"新"のデータ列数（C列〜D列）
> Const clngColumns2 As Long = 2
>
> Dim rngList1 As Range
> Dim vntList1 As Variant
> Dim lngRows1 As Long
> Dim lngComp1 As Long
> Dim vntKeys1 As Variant
> Dim rngList2 As Range
> Dim vntList2 As Variant
> Dim lngRows2 As Long
> Dim lngComp2 As Long
> Dim vntKeys2 As Variant
> Dim lngMatch As Long
> Dim rngResult As Range
> Dim lngWrite As Long
> Dim strProm As String
>
> '"旧"データシートのA1を基準とします
> Set rngList1 = Workbooks("旧.xlsx").Worksheets("旧").Cells(1, "C")
>
> '"新"データシートのA1を基準とする
> Set rngList2 = Workbooks("新.xlsx").Worksheets("新").Cells(1, "C")
>
> '出力シートの基準位置を設定
> Set rngResult = ThisWorkbook.Worksheets("Sheet1").Cells(1, "A")
>
> '"旧"の比較列の列挙(基準セル位置からの列Offsetを列挙)
> 'C列=0、D列=1
> vntKeys1 = Array(0, 1)
> '"新"の比較列の列挙(基準セル位置からの列Offsetを列挙)
> 'C列=0、D列=1
> vntKeys2 = Array(0, 1)
>
> '"旧"の比較データを保持する配列を確保
> ReDim vntList1(0 To UBound(vntKeys1))
> '"新"の比較データを保持する配列を確保
> ReDim vntList2(0 To UBound(vntKeys1))
>
> '画面更新を停止
> Application.ScreenUpdating = False
>
> '"旧"の基準に就いて
> If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
> strProm = rngList1.Parent.Name & "にデータが有りません"
> GoTo Wayout
> End If
>
> '"新"基準に就いて
> If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
> strProm = rngList2.Parent.Name & "にデータが有りません"
> GoTo Wayout
> End If
>
> '"旧"のシートの比較位置
> lngComp1 = 1
> '"新"のシートの比較位置
> lngComp2 = 1
> '"旧"のシート若しくは、"新"のシートが最終行に達するまで繰り返し
> Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
> '各列のデータを比較
> lngMatch = DataCompare(vntList1, lngComp1, vntList2, lngComp2)
> '比較結果に就いて
> Select Case lngMatch
> Case Is = 0 'Matchiした場合
> '出力行位置を更新
> lngWrite = lngWrite + 1
> '行を出力
> With rngResult
> rngList1.Offset(lngComp1).Resize(, clngColumns1).Copy _
> Destination:=.Offset(lngWrite)
> .Offset(lngWrite, clngColumns1).Value = "変更なし"
> End With
> '"新"のシートの比較位置を更新
> lngComp2 = lngComp2 + 1
> '"旧"のシートの比較位置を更新
> lngComp1 = lngComp1 + 1
> Case Is = -1 '"旧"の固有値の場合
> '出力行位置を更新
> lngWrite = lngWrite + 1
> '行を出力
> With rngResult
> rngList1.Offset(lngComp1).Resize(, clngColumns1).Copy _
> Destination:=.Offset(lngWrite)
> .Offset(lngWrite, clngColumns1).Value = "削除"
> End With
> '"旧"のシートの比較位置を更新
> lngComp1 = lngComp1 + 1
> Case Is = 1 '"新"の固有値の場合
> '出力行位置を更新
> lngWrite = lngWrite + 1
> '行を出力
> With rngResult
> rngList2.Offset(lngComp2).Resize(, clngColumns2).Copy _
> Destination:=.Offset(lngWrite)
> .Offset(lngWrite, clngColumns1).Value = "追加"
> End With
> '"新"のシートの比較位置を更新
> lngComp2 = lngComp2 + 1
> End Select
> Loop
>
> '"旧"のシートの順位を復帰
> DataRestore rngList1, lngRows1, clngColumns1
>
> '"新"のシートの順位を復帰
> DataRestore rngList2, lngRows2, clngColumns2
>
> strProm = "処理が完了しました"
>
>Wayout:
>
> '画面更新を再開
> Application.ScreenUpdating = True
>
> Set rngList1 = Nothing
> Set rngList2 = Nothing
> Set rngResult = Nothing
>
> MsgBox strProm, vbInformation
>
>End Sub
>
>Private Function GetBasicData(rngList As Range, _
> lngRows As Long, _
> lngColumns As Long, _
> vntKeys As Variant, _
> vntData As Variant) As Boolean
>
> Dim i As Long
> Dim lngNumb() As Long
>
> '基準に就いて
> With rngList
> '行数を取得
> lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).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
> 'データをvntKeys1列で整列
> For i = UBound(vntKeys) To 0 Step -1
> DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, vntKeys(i))
> Next i
> '比較用配列にデータを取得
> For i = 0 To UBound(vntKeys)
> vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
> Next i
> End With
>
> GetBasicData = True
>
>End Function
>
>Private Sub DataRestore(rngList As Range, lngRows As Long, lngColumns As Long)
>
> With rngList
> '元データ順位を復帰
> DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, lngColumns)
> '復帰用Key列を削除
> .Offset(1, lngColumns).EntireColumn.Delete
> End With
>
>End Sub
>
>Private Sub DataSort(rngScope As Range, _
> rngKey As Range, _
> Optional lngOrientation As Long = xlTopToBottom)
>
> rngScope.Sort _
> Key1:=rngKey, Order1:=xlAscending, _
> Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
> Orientation:=lngOrientation, SortMethod:=xlStroke
>
>End Sub
>
>Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _
> vntKeys2 As Variant, lngPos2 As Long) As Long
>
>' データの大小比較
>
> Dim i As Long
> Dim lngMax As Long
>
> '比較位置がDataEndを超えた場合
> If lngPos1 > UBound(vntKeys1(0), 1) - 1 Then
> DataCompare = 1
> Exit Function
> End If
> If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
> DataCompare = -1
> Exit Function
> End If
>
> '1行の最大比較回数を取得(実際は0から始まる為、回数としては+1と成る)
> lngMax = UBound(vntKeys1, 1)
>
> '1行のKeyを先頭から比較
> For i = 0 To lngMax
> 'もし、Keyが不一致なら
> If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
> 'Forを抜ける
> Exit For
> End If
> Next i
>
> 'Keyが全て一致した場合(Forが全て回り終った場合、iはlngMax+1と成る)
> If i > lngMax Then
> '戻り値の値として、「等しい」を返す
> DataCompare = 0
> Else
> 'vntKeys1の値が、vntKeys2の値因り小さい場合
> If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
> '戻り値の値として、「小さい」を返す
> DataCompare = -1
> Else
> '戻り値の値として、「大きい」を返す
> DataCompare = 1
> End If
> End If
>
>End Function
|
|
みみん
- 09/1/9(金) 3:50 -
