| |
早速のご返信有難うございました！！
早速動かしてみましたが、思ったとおりの結果が得られました。
ほんとすばらしいです。
自分なりに中身を理解したいと思います。
Hirofumiさん、有難うございました。
▼Hirofumi さん：
>基本的にコードを変えてません
>変更した所は、
>各パラメタ（Constで定義されている定数と比較Keyの位置）
>定数項目2個追加（差異列の位置、前回は受注額の後ろとしていた物を独立に）
>変数を2個追加（差異計算用）
>データ復帰に使うKey列を作業列として、L列とX列を使用（前回は先頭No列）
>
>尚、前月Listの先頭に「担当課名」が有りませんが善いのですね？
> 「※A〜K列」と成っているのにレスでは「A〜J列」しか有りませんが？
> もし先頭列に「担当課名」が在るようなら、「★？？？」行を活かして下の行を削除して下さい
>
>Option Explicit
>Option Compare Text
>
>Public Sub DataMatch_2()
>
> '前月のデータ列数（A列〜K列）
> Const clngColumns1 As Long = 11
> '受注額の列位置を指定(基準セルからの列Offset)
>' Const clngItems1 As Long = 7 '★？？？
> Const clngItems1 As Long = 6
> '差異の列位置を指定(基準セルからの列Offset)
>' Const clngDiffer1 As Long = 9 '★？？？
> Const clngDiffer1 As Long = 8
>
> '今月のデータ列数（M列〜W列）
> Const clngColumns2 As Long = 11
> '受注額の列位置を指定(基準セルからの列Offset)
> Const clngItems2 As Long = 7
> '差異の列位置を指定(基準セルからの列Offset)
> Const clngDiffer2 As Long = 9
>
> Dim rngList1 As Range
> Dim vntList1 As Variant
> Dim lngRows1 As Long
> Dim lngComp1 As Long
> Dim vntKeys1 As Variant
> Dim vntResult1 As Variant
> Dim vntTmp1 As Variant
>
> Dim rngList2 As Range
> Dim vntList2 As Variant
> Dim lngRows2 As Long
> Dim lngComp2 As Long
> Dim vntKeys2 As Variant
> Dim vntResult2 As Variant
> Dim vntTmp2 As Variant
>
> Dim lngMatch As Long
> Dim strProm As String
>
> '前月データシートのA1を基準とします
> Set rngList1 = ActiveSheet.Range("A1")
>
> '今月データシートのA1を基準とする
> Set rngList2 = ActiveSheet.Range("M1")
>
> '前月の比較列の列挙(基準セル位置からの列Offsetを列挙)
> 'A列=0、C列=2、E列=4
>' vntKeys1 = Array(2, 3) '★？？？
> vntKeys1 = Array(1, 2)
> '今月の比較列の列挙(基準セル位置からの列Offsetを列挙)
> 'M列=0、O列=2、Q列=4
> vntKeys2 = Array(2, 3)
>
> '前月の比較データを保持する配列を確保
> 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
> Else
> ReDim vntResult1(1 To lngRows1, 1 To 2)
> End If
>
> '今月基準に就いて
> If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
> strProm = rngList2.Parent.Name & "にデータが有りません"
> GoTo Wayout
> Else
> ReDim vntResult2(1 To lngRows2, 1 To 2)
> 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した場合
> '所持金を比較
> vntTmp1 = rngList1.Offset(lngComp1, clngItems1).Value
> vntTmp2 = rngList2.Offset(lngComp2, clngItems2).Value
> If vntTmp1 <> vntTmp2 Then
> vntResult1(lngComp1, 1) = "金額変更"
> vntResult1(lngComp1, 2) = vntTmp2 - vntTmp1
> vntResult2(lngComp2, 1) = "金額変更"
> vntResult2(lngComp2, 2) = vntTmp2 - vntTmp1
> End If
> '前月、今月のシートの比較位置を更新
> lngComp1 = lngComp1 + 1
> lngComp2 = lngComp2 + 1
> Case Is = -1 '前月の固有値の場合
> vntResult1(lngComp1, 1) = "削除"
> '前月のシートの比較位置を更新
> lngComp1 = lngComp1 + 1
> Case Is = 1 '今月の固有値の場合
> vntResult2(lngComp2, 1) = "追加"
> '今月のシートの比較位置を更新
> lngComp2 = lngComp2 + 1
> End Select
> Loop
>
> '結果を出力
> rngList1.Offset(1, clngDiffer1).Resize(lngRows1, 2) = vntResult1
> rngList2.Offset(1, clngDiffer2).Resize(lngRows2, 2) = vntResult2
>
> '前月のシートの順位を復帰
> DataRestore rngList1, lngRows1, clngColumns1
> '今月のシートの順位を復帰
> DataRestore rngList2, lngRows2, clngColumns2
>
> strProm = "処理が完了しました"
>
>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, _
> vntKeys As Variant, _
> vntData As Variant) As Boolean
>
> Dim i 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の出力列を挿入
> .Offset(1, lngColumns).EntireColumn.Insert
> '復帰用整列Keyを作成
> With .Offset(1, lngColumns)
> .Value = 1
> .Resize(lngRows).DataSeries _
> Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
> Step:=1, Trend:=False
> End With
> 'データを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(, 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
>
> 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
>
> lngMax = UBound(vntKeys1, 1)
>
> For i = 0 To lngMax
> If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
> Exit For
> End If
> Next i
>
> If i > lngMax Then
> DataCompare = 0
> Else
> If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
> DataCompare = -1
> Else
> DataCompare = 1
> End If
> End If
>
>End Function
|
|
初心者
- 10/1/13(水) 20:38 -
