| |
ID番号を検索し、IDが有ればその行全てを検索し、
不適合ならば、Sheet3に転記します。
データが10000件以上ありますが、処理速度がとても遅いので
改善箇所が有れば教えて下さい。
宜しくお願いいたします。
Option Explicit
Sub Test6()
Dim vntSheet1 As Variant
Dim vntSheet2 As Variant
Dim vntSheet1Row As Variant
Dim vntSheet2Row As Variant
Dim vntSh1NoID() As Variant
Dim vntSh2NoID() As Variant
Dim vntShData1() As Variant
Dim vntShData2() As Variant
Dim lngSh1Row As Long
Dim lngSh1Cln As Long
Dim lngSh2Row As Long
Dim lngSh2Cln As Long
Dim key1
Dim key2
Dim r As Integer
Dim c As Integer
Dim i As Integer
Dim blnCell As Boolean
Dim mac
Dim Dict
i = 1
blnCell = True
If fncGetSheetData(vntSheet1, lngSh1Row, lngSh1Cln, "Sheet1") = False Then
MsgBox "Sheet1にはデータがありません。"
Exit Sub
End If
If fncGetSheetData(vntSheet2, lngSh2Row, lngSh2Cln, "Sheet2") = False Then
MsgBox "Sheet2にはデータがありません。"
Exit Sub
End If
ReDim vntSh1NoID(1 To lngSh1Row, 1 To lngSh1Cln) As Variant
ReDim vntSh2NoID(1 To lngSh2Row, 1 To lngSh2Cln) As Variant
ReDim vntShData1(1 To lngSh1Row, 1 To 1) As Variant
ReDim vntShData2(1 To lngSh2Row, 1 To 1) As Variant
For i = 1 To lngSh1Row
vntShData1(i, 1) = vntSheet1(i, 1)
Next i
For i = 1 To lngSh2Row
vntShData2(i, 1) = vntSheet2(i, 1)
Next i
i = 1
For r = 1 To lngSh2Row
key1 = vntSheet2(r, 1)
mac = Application.Match(key1, vntShData1, 0)
If IsError(mac) Then
For c = 1 To lngSh2Cln
vntSh2NoID(i, c) = vntSheet2(r, c)
Next c
Set mac = Nothing
Else
For c = 1 To lngSh2Cln
If vntSheet1(r, c) <> vntSheet2(mac, c) Then blnCell = False
Next c
If blnCell = False Then
For c = 1 To lngSh2Cln
vntSh2NoID(i, c) = vntSheet2(r, c)
Next c
i = i + 1
Else
vntSheet2Row = vntSheet2(r, 1)
End If
End If
Set key1 = Nothing
Set mac = Nothing
Next r
Set Dict = Nothing
i = 1
For r = 1 To lngSh1Row
key2 = vntSheet1(r, 1)
mac = Application.Match(key2, vntShData2, 0)
If IsError(mac) Then
For c = 1 To lngSh1Cln
vntSh1NoID(i, c) = vntSheet1(r, c)
Next c
i = i + 1
Set mac = Nothing
End If
Next r
Set mac = Nothing
Worksheets("Sheet3").Range("A1").Resize(lngSh2Row, lngSh2Cln).Value = vntSh2NoID
Worksheets("Sheet4").Range("A1").Resize(lngSh1Row, lngSh1Cln).Value = vntSh1NoID
End Sub
Public Function fncGetSheetData(vntShData As Variant, lngRow As Long, lngCln As Long, strShName As String) As Boolean
fncGetSheetData = False
On Error GoTo err_fncGetSheetData
Dim rngRow As Range
Dim rngCln As Range
Dim strOFName As String
Dim wb
Dim sheetName As String
Application.ScreenUpdating = False
Select Case strShName
Case "Sheet1"
strOFName = "D:\test1.xls"
Case "Sheet2"
strOFName = "D:\test2.xls"
End Select
Set wb = Workbooks.Open(strOFName)
With wb.Worksheets(strShName)
Set rngRow = .Cells.Find("*", , , , xlByRows, xlPrevious)
Set rngCln = .Cells.Find("*", , , , xlByColumns, xlPrevious)
If Not rngRow Is Nothing Then lngRow = rngRow.Row
If Not rngCln Is Nothing Then lngCln = rngCln.Column
vntShData = .Range("A1:" & .Cells(rngRow.Row, rngCln.Column).Address(0, 0))
fncGetSheetData = True
End With
wb.Close savechanges:=False
Application.ScreenUpdating = True
err_fncGetSheetData:
Exit Function
End Function
|
|
どんば
- 04/8/11(水) 22:27 -
