Excel VBA質問箱 IV

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

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


11298 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【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

【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

【16878】Re:ブックの比較
質問  どんば  - 04/8/14(土) 12:48 -

引用なし
パスワード
   Hirofumi さん、有難う御座います。

>コードにコメントも書いて無いので、推測の部分が多々有ります
>特に、「fncGetSheetData」で、どの様なデータで、
>どうやって取得しているのか善く解りません
推測でやってもらい、申し訳御座いませんでした。
問題なく動作し、処理速度も大幅に改善しました。
有難う御座います。

>vntSheet1、vntSheet2のIDがMatchした場合、各列の値を比較し違っている時
IDをkeyにしていますが、選択で文字もID同様にMatchしています。
文字の場合も同様のやり方(現在、作成中)で宜しいのでしょうか。

>また、「fncGetSheetData」のデータ取得方法が善く解らない為、
他のデータ(文書等)もあり、空白行・列など大量にある為、
シート全体に対し、最終行・列を取得しています。

>各Bookのデータは、A1から有る物としてCurrentRegionで取得しています
項目行も変更対象なので、比較対照にしています。

>尚、データに列見出しは無いとしていますし、
>ソートしていない前提でソートを行っています
>  '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

          'Sheet3にMatchしないセルに色を塗る
          wksSheet3.Cells(lngSh3Row, i) _
                .Interior.ColorIndex = 4

>          '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
Sheet3にMatchしないセルに色を塗りたいのですが、
最後にメッセージにてMatchしないセルに色を塗るか選択したい為、
どの様にしたら宜しいでしょうか。

宜しくお願いいたします。

【16884】Re:ブックの比較
回答  Hirofumi  - 04/8/14(土) 15:07 -

引用なし
パスワード
   >>vntSheet1、vntSheet2のIDがMatchした場合、各列の値を比較し違っている時
>IDをkeyにしていますが、選択で文字もID同様にMatchしています。
>文字の場合も同様のやり方(現在、作成中)で宜しいのでしょうか。

文字の場合も同様のやり方で出来ます
ただ、今回の様に、比較する文字列の有る列が、比較する文字列をKeyとして
Sheet1、Sheet2共に昇順にソートされているのが条件です
また、「Option Compare Text」を必ず入れて下さい
Excelでソートした場合、此れを入れないと、コードの比較順と結果が変わりますので

>>また、「fncGetSheetData」のデータ取得方法が善く解らない為、
>他のデータ(文書等)もあり、空白行・列など大量にある為、
>シート全体に対し、最終行・列を取得しています。

>>各Bookのデータは、A1から有る物としてCurrentRegionで取得しています
>項目行も変更対象なので、比較対照にしています。

「Function fncGetSheetData」は、中を替えていますが
インターファイスは替えていない為、どんばさん本来のコードでも
ソートの部分を追加すれば使えると思います

>Sheet3にMatchしないセルに色を塗りたいのですが、
>最後にメッセージにてMatchしないセルに色を塗るか選択したい為、
>どの様にしたら宜しいでしょうか。

この部分の修正は、以下の様に成ります

「Sub Test7」の中で

  Dim blnNoMatch As Boolean
  Dim j As Long        '◎追加
  Dim vntNoMatch() As Variant '◎追加
  Dim blnPaint As Boolean   '◎追加


  'Matchしないセルの色塗り選択  ◎追加
  If MsgBox("Matchしないセルに色を塗ります", _
      vbInformation + vbYesNo, "Paint") = vbYes Then '◎追加
    blnPaint = True '◎追加
  End If '◎追加
  
  '"D:\test1.xls"からのデータ取得
  If Not fncGetSheetData(vntSheet1, lngSh1Row, _
                lngSh1Cln, "Sheet1") Then


      '列側のデータの比較
      blnNoMatch = False
      j = 0                      '◎追加
      For i = 1 To lngSh2Cln
        If vntSheet1(lngSh1Pos, i) _
              <> vntSheet2(lngSh2Pos, i) Then
          blnNoMatch = True
          j = j + 1                '◎追加
          ReDim Preserve vntNoMatch(1 To j)    '◎追加
          vntNoMatch(j) = i - 1          '◎追加
'          Exit For                '★削除
        End If
      Next i
      'データが一致しない場合
      If blnNoMatch Then
        'Sheet3に行データを書き込み
        ResultWrite vntSheet2, lngSh2Pos, _
              lngSh2Cln, wksSheet3, lngSh3Row
        If blnPaint Then               '◎追加
          PaintingInterior vntNoMatch, _
                    wksSheet3, lngSh3Row '◎追加
        End If                    '◎追加
      End If


以下のプロシージャを追加

Private Sub PaintingInterior(vntColor As Variant, _
              wksWrite As Worksheet, _
              lngWriteRow As Long)

'  セルの色塗り

  Dim i As Long
  
  With wksWrite.Cells(lngWriteRow, 1)
    For i = 1 To UBound(vntColor)
      .Offset(-1, vntColor(i)).Interior.ColorIndex = 34
    Next i
  End With

End Sub


PS:
 話は変わりますが、どんばさんが最初に書いたコード
 私のコードを下敷きにしていますか?
 某所のレスも見ましたが、コメントの付け方、変数名等が、
 私のコードの雰囲気にソックリな物で?

【16891】Re:ブックの比較
お礼  どんば  - 04/8/14(土) 18:32 -

引用なし
パスワード
   Hirofumi さん、度々有難うございます。

>PS:
> 話は変わりますが、どんばさんが最初に書いたコード
> 私のコードを下敷きにしていますか?
> 某所のレスも見ましたが、コメントの付け方、変数名等が、
> 私のコードの雰囲気にソックリな物で?
私のコードはAccessの某サイトにて独学で勉強した為、
某サイトのコードの書き方に似ています。
様々なサイトにて検索し参考にしているので、
Hirofumiさんのコードに似ているのかもしれません。

また、何か有りましたら宜しくお願いたします。

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