Excel VBA質問箱 IV

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

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


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

9753 / 76734

←次へ　｜　前へ→


	【72539】Re:明細の再確認

UO3 - 12/8/21(火) 11:49 -


	引用なし

	パスワード

▼杏子さん：

それでは、総入れ替えで。
比較タイトル規定、従来はA,B 一本でしたが、別々にそれぞれ規定します。
以下のコードでは、B　のほうを契約金額としています。
もし違っていれば変更してください。

Sub Sample3()
　　Dim dicA As Object
　　Dim dicB As Object
　　Dim dicAonly As Object
　　Dim dicBonly As Object
　　Dim d As Variant
　　Dim colA() As Variant
　　Dim colB() As Variant
　　Dim shA As Worksheet
　　Dim shB As Worksheet
　　Dim c As Range
　　Dim vntTitleA As Variant
　　Dim vntTitleB As Variant
　　
　　vntTitleA = Array("型名", "数量", "合価", "構成GC")
　　vntTitleB = Array("型名", "数量", "契約金額", "構成GC")
　　
　　If UBound(vntTitleA) <> UBound(vntTitleB) Then
　　　　MsgBox "比較タイトル規定に関するプログラムエラーです。" & vbLf & _
　　　　　　　 "処理を終了します"
　　　　Exit Sub
　　End If
　　
　　ReDim colA(1 To UBound(vntTitleA) + 1)
　　ReDim colB(1 To UBound(vntTitleB) + 1)
　　
　　Set dicA = CreateObject("Scripting.Dictionary")
　　Set dicB = CreateObject("Scripting.Dictionary")
　　Set dicAonly = CreateObject("Scripting.Dictionary")
　　Set dicBonly = CreateObject("Scripting.Dictionary")
　
　　Set shA = Sheets("Sheet1")
　　Set shB = Sheets("Sheet2")
　
　　If Not GetCol(shA, colA, vntTitleA) Then Exit Sub
　　If Not GetCol(shB, colB, vntTitleB) Then Exit Sub
　
　　CreateDic shA, dicA, colA
　　CreateDic shB, dicB, colB
　
　　OnlyCheck shA, dicA, dicB, dicAonly, colA
　　OnlyCheck shB, dicB, dicA, dicBonly, colB
　
　　If dicAonly.Count = 0 Then
　　　　MsgBox "資料(A)にある内容はすべて資料(B)と同じでした"
　　Else
　　　　shA.Select
　　　　MsgBox "資料(A)のうち、以下が資料(B)にありません" & vbLf & Join(dicAonly.keys, vbLf)
　　End If
　
　　If dicBonly.Count = 0 Then
　　　　MsgBox "資料(B)にある内容はすべて資料(A)と同じでした"
　　Else
　　　　shB.Select
　　　　MsgBox "資料(B)のうち、以下が資料(A)にありません" & vbLf & Join(dicBonly.keys, vbLf)
　　End If
　
　
End Sub

Private Function GetCol(sh As Worksheet, v As Variant, vntT As Variant) As Boolean
　　Dim x As Long
　　Dim ck As String
　　Dim z As Variant
　　
　　x = UBound(vntT) + 1
　　For x = 1 To x
　　　　ck = vntT(x - 1)
　　　　z = Application.Match(ck, sh.Rows(1), 0)
　　　　If IsError(z) Then
　　　　　　MsgBox sh.Name & "のタイトル行に" & ck & "がないので処理を終了します"
　　　　　　Exit Function
　　　　End If
　　　　v(x) = z
　　　　sh.UsedRange.Columns(z).Interior.ColorIndex = xlNone
　　Next
　　GetCol = True
End Function

Private Sub CreateDic(sh As Worksheet, dic As Object, v As Variant)
　　Dim c As Range
　　Dim sep As String
　　Dim d As Variant
　　Dim dKey As String
　　
　　For Each c In sh.Range("A2", sh.Range("A" & sh.Rows.Count).End(xlUp))
　　　　dKey = ""
　　　　sep = ""
　　　　For Each d In v
　　　　　　dKey = dKey & sep & c.Offset(, d - 1).Value
　　　　　　sep = "/"
　　　　Next
　　　　dic(dKey) = c.Row
　　Next
　　
End Sub

Private Sub OnlyCheck(sh As Worksheet, dic1 As Object, dic2 As Object, dicOnly As Object, v As Variant)
　　Dim d As Variant
　　Dim n As Variant
　　
　　For Each d In dic1
　　　　If Not dic2.exists(d) Then
　　　　　　dicOnly(d) = True
　　　　　　For Each n In v
　　　　　　　　sh.Cells(dic1(d), n).Interior.Color = vbRed
　　　　　　Next
　　　　End If
　　Next
End Sub

11 hits

▼

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