Excel VBA質問箱 IV

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

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


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

9760 / 76738

←次へ　｜　前へ→


	【72536】Re:明細の再確認

UO3 - 12/8/20(月) 12:18 -


	引用なし

	パスワード

▼杏子さん：

以下でお試しください。

Sub Sample2()
　　Dim dicA As Object
　　Dim dicB As Object
　　Dim dicAonly As Object
　　Dim dicBonly As Object
　　Dim dicComp 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 vntTitle As Variant
　
　　vntTitle = Array("型名", "数量", "合価", "構成GC")
　　
　　ReDim colA(1 To UBound(vntTitle) + 1)
　　ReDim colB(1 To UBound(vntTitle) + 1)
　　
　　Set dicA = CreateObject("Scripting.Dictionary")
　　Set dicB = CreateObject("Scripting.Dictionary")
　　Set dicAonly = CreateObject("Scripting.Dictionary")
　　Set dicBonly = CreateObject("Scripting.Dictionary")
　　Set dicComp = CreateObject("Scripting.Dictionary")
　
　　Set shA = Sheets("Sheet1")
　　Set shB = Sheets("Sheet2")
　
　　If Not GetCol(shA, colA, vntTitle) Then Exit Sub
　　If Not GetCol(shB, colB, vntTitle) Then Exit Sub
　
　　CreateDic shA, dicA, colA
　　CreateDic shB, dicB, colB
　
　　OnlyCheck dicA, dicB, dicAonly
　　OnlyCheck dicB, dicA, dicBonly
　
　　If dicAonly.Count = 0 Then
　　　　MsgBox "資料(A)にある内容はすべて資料(B)と同じでした"
　　Else
　　　　MsgBox "資料(A)のうち、以下が資料(B)にありません" & vbLf & Join(dicAonly.keys, vbLf)
　　End If
　
　　If dicBonly.Count = 0 Then
　　　　MsgBox "資料(B)にある内容はすべて資料(A)と同じでした"
　　Else
　　　　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
　　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) = True
　　Next
　　
End Sub

Private Sub OnlyCheck(dic1 As Object, dic2 As Object, dicOnly As Object)
　　Dim d As Variant
　　For Each d In dic1
　　　　If Not dic2.exists(d) Then dicOnly(d) = True
　　Next
End Sub

0 hits

▼

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