Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


64462 / 76732 ←次へ | 前へ→

【16851】ブックの比較
質問  どんば  - 04/8/11(水) 22:27 -

引用なし
パスワード
   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
0 hits

【16851】ブックの比較 どんば 04/8/11(水) 22:27 質問
【16858】Re:ブックの比較 Hirofumi 04/8/12(木) 10:50 回答
【16878】Re:ブックの比較 どんば 04/8/14(土) 12:48 質問
【16884】Re:ブックの比較 Hirofumi 04/8/14(土) 15:07 回答
【16891】Re:ブックの比較 どんば 04/8/14(土) 18:32 お礼

64462 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free