Excel VBA質問箱 IV

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

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


64455 / 76732 ←次へ | 前へ→

【16858】Re:ブックの比較
回答  Hirofumi  - 04/8/12(木) 10:50 -

引用なし
パスワード
   コードにコメントも書いて無いので、推測の部分が多々有ります
特に、「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
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 お礼

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