| |
コードにコメントも書いて無いので、推測の部分が多々有ります
特に、「fncGetSheetData」で、どの様なデータで、どうやって取得しているのか善く解りません
一応の解釈は、"D:\test1.xls"、"D:\test2.xls"のデータを配列に取得
vntSheet1、vntSheet2のIDがMatchした場合、各列の値を比較し違っている時
Sheet3に行データを書き込み
vntSheet2にしか無いIDの場合、Sheet3に行データを書き込み
vntSheet1にしか無いIDの場合、Sheet4に行データを書き込み
としています
また、「fncGetSheetData」のデータ取得方法が善く解らない為、
各Bookのデータは、A1から有る物としてCurrentRegionで取得しています
尚、データに列見出しは無いとしていますし、ソートしていない前提でソートを行っています
上手く行かなかったらゴメン
結果の書き込みを行単位で行って居るので余り早くは有りませんが、
上手く行けば幾分早く成ると思います
Option Explicit
Option Compare Text
Sub Test7()
Dim i As Long
Dim vntSheet1 As Variant
Dim vntSheet2 As Variant
Dim lngSh1Row As Long
Dim lngSh1Cln As Long
Dim lngSh1Pos As Long
Dim lngSh2Row As Long
Dim lngSh2Cln As Long
Dim lngSh2Pos As Long
Dim wksSheet3 As Worksheet
Dim lngSh3Row As Long
Dim wksSheet4 As Worksheet
Dim lngSh4Row As Long
Dim blnNoMatch As Boolean
'"D:\test1.xls"からのデータ取得
If Not fncGetSheetData(vntSheet1, lngSh1Row, _
lngSh1Cln, "Sheet1") Then
MsgBox "Sheet1にはデータがありません。"
Exit Sub
End If
'Sheet1データの読み出し行の設定（ポインタ初期値）
lngSh1Pos = 1
'"D:\test2.xls"からのデータ取得
If Not fncGetSheetData(vntSheet2, lngSh2Row, _
lngSh2Cln, "Sheet2") Then
MsgBox "Sheet2にはデータがありません。"
Exit Sub
End If
'Sheet2データの読み出し行の設定（ポインタ初期値）
lngSh2Pos = 1
'結果書き込み用シートの設定
Set wksSheet3 = Worksheets("Sheet3")
'書き込み位置の設定（ポインタ初期値）
lngSh3Row = 1
Set wksSheet4 = Worksheets("Sheet4")
lngSh4Row = 1
Application.ScreenUpdating = False
'vntSheet1、vntSheet2どちらかのデータが無くなるまで繰り返し
Do Until lngSh1Pos > lngSh1Row Or lngSh2Pos > lngSh2Row
'vntSheet1、vntSheet2のIDがMatchした場合
If vntSheet1(lngSh1Pos, 1) = vntSheet2(lngSh2Pos, 1) Then
'列側のデータの比較
blnNoMatch = False
For i = 1 To lngSh2Cln
If vntSheet1(lngSh1Pos, i) _
<> vntSheet2(lngSh2Pos, i) Then
blnNoMatch = True
Exit For
End If
Next i
'データが一致しない場合
If blnNoMatch Then
'Sheet3に行データを書き込み
ResultWrite vntSheet2, lngSh2Pos, _
lngSh2Cln, wksSheet3, lngSh3Row
End If
'vntSheet1、vntSheet2の読み込みポインタを更新
lngSh1Pos = lngSh1Pos + 1
lngSh2Pos = lngSh2Pos + 1
Else
'vntSheet2にしか無いIDの場合
If vntSheet1(lngSh1Pos, 1) > vntSheet2(lngSh2Pos, 1) Then
'Sheet3に行データを書き込み
ResultWrite vntSheet2, lngSh2Pos, _
lngSh2Cln, wksSheet3, lngSh3Row
'vntSheet2の読み込みポインタを更新
lngSh2Pos = lngSh2Pos + 1
'vntSheet1にしか無いIDの場合
Else
'Sheet4に行データを書き込み
ResultWrite vntSheet1, lngSh1Pos, _
lngSh1Cln, wksSheet4, lngSh4Row
'vntSheet1の読み込みポインタを更新
lngSh1Pos = lngSh1Pos + 1
End If
End If
Loop
'vntSheet1にデータが残っている場合
For i = lngSh1Pos To lngSh1Row
'Sheet4に残りの行データを書き込み
ResultWrite vntSheet1, i, _
lngSh1Cln, wksSheet4, lngSh4Row
Next i
'vntSheet2にデータが残っている場合
For i = lngSh2Pos To lngSh2Row
'Sheet3に残りの行データを書き込み
ResultWrite vntSheet2, i, _
lngSh2Cln, wksSheet3, lngSh3Row
Next i
Application.ScreenUpdating = True
Set wksSheet3 = Nothing
Set wksSheet4 = Nothing
Beep
MsgBox "処理が完了しました"
End Sub
Public Function fncGetSheetData(vntShData As Variant, _
lngRow As Long, _
lngCln As Long, _
strShName As String) As Boolean
Dim strOFName As String
Dim wkbData As Workbook
Dim rngScope As Range
Application.ScreenUpdating = False
fncGetSheetData = False
On Error GoTo err_fncGetSheetData
Select Case strShName
Case "Sheet1"
' strOFName = "D:\test1.xls"
strOFName = ThisWorkbook.Path & "\" & "VBATest418DataB.xls"
Case "Sheet2"
' strOFName = "D:\test2.xls"
strOFName = ThisWorkbook.Path & "\" & "VBATest418DataA.xls"
End Select
Set wkbData = Workbooks.Open(strOFName)
With wkbData.Worksheets(strShName)
'OpenしたBookのデータ範囲を取得
Set rngScope = .Cells(1, "A").CurrentRegion
End With
With rngScope
'行数を取得
lngRow = .Rows.Count
'列数を取得
lngCln = .Columns.Count
'1列1行で無い場合（データが無い場合）
If Not (lngRow = 1 And lngCln = 1) Then
'IDに就いて並べ替え（データが並べ替えて無い場合）
.Sort _
key1:=.Item(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'データを配列に取得
vntShData = .Value
fncGetSheetData = True
End If
End With
wkbData.Close SaveChanges:=False
err_fncGetSheetData:
Set rngScope = Nothing
Application.ScreenUpdating = True
End Function
Private Sub ResultWrite(vntSheet As Variant, _
lngRow As Long, _
lngCol As Long, _
wksWrite As Worksheet, _
lngWriteRow As Long)
' 結果の書き込み
Dim i As Long
Dim vntResult As Variant
ReDim vntResult(1 To 1, 1 To lngCol)
For i = 1 To lngCol
vntResult(1, i) = vntSheet(lngRow, i)
Next i
With wksWrite.Cells(lngWriteRow, 1)
.Resize(, lngCol).Value = vntResult
End With
lngWriteRow = lngWriteRow + 1
End Sub
|
|
Hirofumi
- 04/8/12(木) 10:50 -
