[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『大量のデータの変更箇所を色づけマクロ』（かっぷ）
お世話になります。
大量のデータがあります。
Ａ列には項番 Ｂ列には新規・変更いづれか Ｃ列には日付 Ｄ列には店番 Ｅ列には名前といった具合にＺ列までそれぞれお店毎の情報が続きます。
１行から２００行くらいまであり、新しいお店が入ったら行を挿入して増えていきます。
毎週更新されるのですが、先週と今週ので何処が変わったのか（例えば日付とか） 分からない為、マクロかなにかで、今週のデータに先週と変わったところを 色付けして一目で分かるようにしたいのですが、御教授頂けませんでしょうか。
エクセル2003です
よろしくお願い致します。
変わらないものは何ですか。例えばある店が、他の店を買い取って、その店を今までの名前で経営する場合。その店の住所その他多くの項目は変わらないと思います。 その店が引っ越して住所が変わったのか、店の名前が変わったのか？ (NB)
変わらないものはありません。
例えばある店でも店舗名をいじってしまったり、追加挿入すればその行には新しい店舗名が 入ります。
以前、使用していたマクロで、 先週のファイル名と今週のファイル名、 色付けしたいファイル名を入れて入力し、 「実行」ボタンを押すと、マクロが動いて、表示させるというのを使っていました。
だいぶ前すぎてどこにそのファイルがあるかも分からないので 今回再度尋ねてみました。。
（かっぷ）
行の挿入が無ければ、かなり簡単に組めると思います。 場合によっては条件付き書式だけでも可能でしょう。
でも、挿入されてセル位置が変わったりデータ的にも変わらないものが無いとなると 何を絶対的なものとして比較すれば良いのかわかりません。 せめて連番だけでも変わらないような仕組みにしないと比較対象がわからないのでは？
（ｍｏｍｏ）
一番下の行に追加されるデータもありますが 急遽、開店するお店の場合、開店作業をする日付順で行を挿入する形になります。
その為、絶対的に変わらないものとしては店番号です。
項番も更新されていくので やはり比較は不可能でしょうか。
イメージとしては先週と今週では、追加されるデータは２０件くらい、 変更されているデータは１０件くらい、 ザっとみた感じで変更されている箇所が蛍光色のセルで表示できたらな。とおもうのです。
ｍｏｍｏさんのおっしゃっている、条件付き書式だけでも可能、というやり方、
是非教えていただけませんでしょうか。
行の挿入がないということ前提で伺いたいと思います。
よろしくお願いします。
（かっぷ）
先週のデータと今週のデータはどこにあるのですか？ 同じブックの同じシート？ 同じブックの違うシート？ 違うブック？
条件付き書式なら、単純に先週と今週の同じセル位置の値が違えば色を付ける。 という設定にするだけです。 （ｍｏｍｏ）
とりあえず、店番号が不変という条件でしたら以下のような感じで出来るとは思いますが
Sub test() Dim myRng1 As Range, myRng2 As Range Dim tbl1 As Variant, tbl2 As Variant Dim i As Long, j As Long, myRow As Long
Set myRng1 = Worksheets("Sheet1").Range("A1").CurrentRegion '先週データ範囲
Set myRng2 = Worksheets("Sheet2").Range("A1").CurrentRegion '今週データ範囲
tbl1 = myRng1.Value
tbl2 = myRng2.Value
For i = 1 To UBound(tbl2)
myRow = 0
On Error Resume Next
With Application.WorksheetFunction
myRow = .Match(tbl2(i, 4), .Index(tbl1, 0, 4), 0)
End With
On Error GoTo 0
If myRow = 0 Then
myRng2.Rows(i).Interior.ColorIndex = 8
Else
For j = 1 To 26
If tbl1(myRow, j) <> tbl2(i, j) Then
myRng2.Cells(i, j).Interior.ColorIndex = 6
End If
Next j
End If
Next i
End Sub
取り合えずこんなのでは？
先週のList、今週のListには、列見出しが有る物とします
Option Explicit
Public Sub DataMatch()
'先週Listのデータ列数（A列～Z列）
Const clngColumnsA As Long = 26
'先週Listの比較する列の列位置(基準セル位置からの列Offset：D列)
Const clngKeysA As Long = 3
'今週Listのデータ列数（A列～Z）
Const clngColumnsB As Long = 26
'今週Listの比較する列の列位置(基準セル位置からの列Offset：D列)
Const clngKeysB As Long = 3
Dim i As Long
Dim rngListA As Range
Dim vntListA As Variant
Dim lngRowsA As Long
Dim lngCompA As Long
Dim vntDataA() As Variant
Dim rngListB As Range
Dim vntListB As Variant
Dim lngRowsB As Long
Dim lngCompB As Long
Dim vntDataB() As Variant
Dim lngMatch As Long
Dim strProm As String
'先週ListのA1を基準とします(列見出しが有るとします)
Set rngListA = Worksheets("Sheet1").Cells(1, "A")
'今週ListのA1を基準とする(列見出しが有るとします)
Set rngListB = Worksheets("Sheet2").Cells(1, "A")
'画面更新を停止
Application.ScreenUpdating = False
'先週Listの基準に就いて
If Not GetBasicData(rngListA, lngRowsA, clngColumnsA, clngKeysA, vntListA) Then
strProm = rngListA.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'今週List基準に就いて
If Not GetBasicData(rngListB, lngRowsB, clngColumnsB, clngKeysB, vntListB) Then
strProm = rngListB.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
rngListA.Offset(1).Resize(lngRowsA, clngColumnsA).Interior.ColorIndex = xlNone
rngListB.Offset(1).Resize(lngRowsB, clngColumnsB).Interior.ColorIndex = xlNone
'先週Listの比較位置
lngCompA = 1
'今週Listの比較位置
lngCompB = 1
'先週List今週Listが共に最終行に達するまで繰り返し
Do Until lngCompA > lngRowsA And lngCompB > lngRowsB
'各列のデータを比較
lngMatch = DataCompare(vntListA, lngCompA, vntListB, lngCompB)
'比較結果に就いて
Select Case lngMatch
Case Is = 0 'Matchiした場合
'1行分のデータを先週、今週Listから取得
vntDataA = rngListA.Offset(lngCompA).Resize(, clngColumnsA).Value
vntDataB = rngListB.Offset(lngCompB).Resize(, clngColumnsB).Value
'データを比較
For i = 1 To clngColumnsA
If vntDataA(1, i) <> vntDataB(1, i) Then
'InteriorColorを変更
rngListA.Offset(lngCompA, i - 1).Interior.ColorIndex = 34
rngListB.Offset(lngCompB, i - 1).Interior.ColorIndex = 34
End If
Next i
'先週Listの比較位置を更新
lngCompA = lngCompA + 1
'今週Listの比較位置を更新
lngCompB = lngCompB + 1
Case Is = -1 '先週Listの固有値の場合
'InteriorColorを変更
rngListA.Offset(lngCompA).Resize(, clngColumnsA).Interior.ColorIndex = 35
'先週Listのシートの比較位置を更新
lngCompA = lngCompA + 1
Case Is = 1 '今週Listの固有値の場合
'InteriorColorを変更
rngListB.Offset(lngCompB).Resize(, clngColumnsB).Interior.ColorIndex = 35
'今週Listの比較位置を更新
lngCompB = lngCompB + 1
End Select
Loop
With rngListA
'データの順番を元に戻す
DataSort .Offset(1).Resize(lngRowsA, clngColumnsA + 1), .Offset(1, clngColumnsA)
'復帰用連番を消去
.Offset(1, clngColumnsA).EntireColumn.Clear
End With
With rngListB
'データの順番を元に戻す
DataSort .Offset(1).Resize(lngRowsB, clngColumnsB + 1), .Offset(1, clngColumnsB)
'復帰用連番を消去
.Offset(1, clngColumnsB).EntireColumn.Clear
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngListA = Nothing
Set rngListB = 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
'基準に就いて
With rngList
'行数を取得
lngRows = .Offset(.Parent.Rows.Count - .Row, lngKeys).End(xlUp).Row - .Row
'データが無ければFunctionを抜ける(戻り値=False)
If lngRows <= 0 Then
Exit Function
End If
'最終列の後ろに復帰用連番を付与します
With .Offset(1, lngColumns)
.Value = 1
.Resize(lngRows).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End With
'データをlngKeys列で整列
DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, lngKeys)
'比較用配列にデータを取得
vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
End With
GetBasicData = True
End Function
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
' データの大小比較
'比較位置がDataEndを超えた場合
If lngPos1 > UBound(vntKeys1, 1) - 1 Then
DataCompare = 1
Exit Function
End If
If lngPos2 > UBound(vntKeys2, 1) - 1 Then
DataCompare = -1
Exit Function
End If
'もし、Keyが不一致なら
If vntKeys1(lngPos1, 1) = vntKeys2(lngPos2, 1) Then
'戻り値の値として、「等しい」を返す
DataCompare = 0
Else
'vntKeys1の値が、vntKeys2の値因り小さい場合
If vntKeys1(lngPos1, 1) < vntKeys2(lngPos2, 1) Then
'戻り値の値として、「小さい」を返す
DataCompare = -1
Else
'戻り値の値として、「大きい」を返す
DataCompare = 1
End If
End If
End Function
(Bun)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.