Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

9854 / 76807

←次へ　｜　前へ→


	【72511】Re:明細の再確認

UO3 - 12/8/18(土) 11:12 -


	引用なし

	パスワード

▼杏子さん：

こんにちは

資料Ａも資料Ｂも，マクロブックのシートに貼り付けてあるという前提です。
比較後、相違をメッセージで表示します。

Sub Sample()
　　Dim shA As Worksheet
　　Dim shB As Worksheet
　　Dim x As Double
　　Dim y As Double
　　Dim rA As Range, rB As Range
　　Dim i As Long
　　Dim j As Long
　　Dim v() As String
　　Dim k As Long
　　Dim dataA As Variant
　　Dim dataB As Variant
　　
　　Set shA = Sheets("Sheet1")　'資料A
　　Set shB = Sheets("Sheet2")　'資料B
　　
　　With shA.UsedRange
　　　　x = .Cells(.Cells.Count).Column
　　　　y = .Cells(.Cells.Count).Row
　　End With
　　
　　With shB.UsedRange
　　　　x = WorksheetFunction.Max(x, .Cells(.Cells.Count).Column)
　　　　y = WorksheetFunction.Max(y, .Cells(.Cells.Count).Row)
　　End With
　　　　
　　Set rA = shA.Range("A2", shA.Cells(y, x))
　　Set rB = shB.Range("A2", shB.Cells(y, x))
　　
　　ReDim v(1 To rA.Count)
　　
　　For i = 1 To rA.Rows.Count
　　　　For j = 1 To rA.Columns.Count
　　　　　　If shA.Cells(i, j).Formula <> shB.Cells(i, j).Formula Then
　　　　　　　　k = k + 1
　　　　　　　　dataA = shA.Cells(i, j).Formula
　　　　　　　　dataB = shB.Cells(i, j).Formula
　　　　　　　　If Len(dataA) = 0 Then dataA = "空白値"
　　　　　　　　If Len(dataB) = 0 Then dataB = "空白値"
　　　　　　　　
　　　　　　　　v(k) = shA.Cells(i, j).Address(False, False) & " (A) " & dataA & " vs (B) " & dataB
　　　　　　End If
　　　　Next
　　Next
　　
　　If k = 0 Then
　　　　MsgBox "相違はありません"
　　Else
　　　　ReDim Preserve v(1 To k)
　　　　MsgBox "以下の相違がありました" & vbLf & Join(v, vbLf)
　　End If
　　　　　　
End Sub

1 hits

▼

【72509】明細の再確認 杏子 12/8/18(土) 9:20