Excel VBA質問箱 IV

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

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


3340 / 13646 ツリー ←次へ | 前へ→

【62842】シート全体の比較 りな 09/9/8(火) 15:57 質問[未読]
【62850】Re:シート全体の比較 arajin 09/9/8(火) 23:09 回答[未読]
【62851】Re:シート全体の比較 りな 09/9/9(水) 7:36 お礼[未読]

【62842】シート全体の比較
質問  りな  - 09/9/8(火) 15:57 -

引用なし
パスワード
   2つのファイルで、同じシート名のもののセルを全部比較したいのですが、
どこまでデータが入っているか、未確定として、比較すると
行数65536、列数256でloopを回すしかないでしょうか?
LOOPするとすごい時間がかかります。
シート数も多数あるので、もっと短時間で終わる方法を教えてもらえないでしょうか。

【62850】Re:シート全体の比較
回答  arajin  - 09/9/8(火) 23:09 -

引用なし
パスワード
   回答が付きませんね〜。
比較の対象がセルの値のみでいいと言うことであれば、
次のような考えではどうですか?
第3のシートに、二つのシートの値を比較する数式を書いて、
その結果で判断するとかです。

比較した結果をどんな形でアウトプットするのか不明ですが、
以下のサンプルでは、異なる値のセルの背景色を黄色に色付けします。

Sub セル同士の比較()
  Dim wb1 As Workbook, wb2 As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim tmpSht As Worksheet, tmpR As Range
  Dim r As Range
  Dim cnt As Long, v() As String, x As Variant
  
  Set wb1 = Workbooks("book1.xls")
  Set wb2 = Workbooks("book2.xls")
  Set tmpSht = ThisWorkbook.Worksheets.Add
  For Each ws1 In wb1.Worksheets
    On Error Resume Next
    Set ws2 = wb2.Worksheets(ws1.Name)
    On Error GoTo 0
    If Not ws2 Is Nothing Then
      With ws1
  '      Set tmpR = Intersect(.UsedRange, .Range(ws2.UsedRange.Address))
        Set tmpR = .Range(.UsedRange, .Range(ws2.UsedRange.Address))
      End With
  '    If tmpR Is Nothing Then Exit Sub
      With tmpSht
        .Cells.ClearContents
        With .Range(tmpR.Address)
          .FormulaR1C1 = "=IF('[" & ws1.Parent.Name & "]" & ws1.Name & "'!RC=" _
                   & "'[" & ws2.Parent.Name & "]" & ws2.Name & "'!RC,"""",1)"
          cnt = Application.WorksheetFunction.Count(.Cells)
          If cnt > 0 Then
            v = Split("")
            For Each r In .SpecialCells(xlCellTypeFormulas, xlNumbers).Areas
              ReDim Preserve v(UBound(v) + 1)
              v(UBound(v)) = r.Address(0, 0)
            Next
          End If
        End With
      End With
      If cnt > 0 Then
        On Error Resume Next
        For Each x In v
          ws1.Range(x).Interior.Color = vbYellow
          ws2.Range(x).Interior.Color = vbYellow
        Next
        On Error GoTo 0
      End If
      Debug.Print ws1.Name, IIf(cnt > 0, cnt & " 個の相違セルがあります。", "相違セルはなし")
      Set ws2 = Nothing
    End If
  Next
  Application.DisplayAlerts = False
  tmpSht.Delete
  Application.DisplayAlerts = True
End Sub

【62851】Re:シート全体の比較
お礼  りな  - 09/9/9(水) 7:36 -

引用なし
パスワード
   arajinさん

ありがとうございます。
試してみました。期待以上の結果にとても満足しています。
しかも、処理が早い!!!
アウトプットの仕方は自分で変更して考えてみます。

本当に助かりました。
感謝してます。ありがとうございました。

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