Excel VBA質問箱 IV

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

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


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

【72509】明細の再確認 杏子 12/8/18(土) 9:20 質問[未読]
【72511】Re:明細の再確認 UO3 12/8/18(土) 11:12 発言[未読]
【72512】Re:明細の再確認 杏子 12/8/18(土) 15:31 質問[未読]
【72515】Re:明細の再確認 UO3 12/8/18(土) 20:54 発言[未読]
【72516】Re:明細の再確認 杏子 12/8/19(日) 13:12 発言[未読]
【72517】Re:明細の再確認 UO3 12/8/19(日) 14:41 発言[未読]
【72518】Re:明細の再確認 杏子 12/8/19(日) 15:02 発言[未読]
【72520】Re:明細の再確認 UO3 12/8/19(日) 16:15 発言[未読]
【72521】Re:明細の再確認 杏子 12/8/19(日) 16:27 発言[未読]
【72523】Re:明細の再確認 UO3 12/8/19(日) 17:25 発言[未読]
【72524】Re:明細の再確認 杏子 12/8/19(日) 17:32 発言[未読]
【72525】Re:明細の再確認 UO3 12/8/19(日) 17:34 発言[未読]
【72527】Re:明細の再確認 杏子 12/8/19(日) 18:58 発言[未読]
【72528】Re:明細の再確認 UO3 12/8/19(日) 19:17 発言[未読]
【72529】Re:明細の再確認 杏子 12/8/19(日) 19:30 発言[未読]
【72533】Re:明細の再確認 杏子 12/8/20(月) 9:32 発言[未読]
【72536】Re:明細の再確認 UO3 12/8/20(月) 12:18 発言[未読]
【72537】Re:明細の再確認 杏子 12/8/21(火) 6:23 質問[未読]
【72538】Re:明細の再確認 杏子 12/8/21(火) 10:37 質問[未読]
【72539】Re:明細の再確認 UO3 12/8/21(火) 11:49 発言[未読]
【72540】Re:明細の再確認 杏子 12/8/21(火) 12:14 質問[未読]
【72541】Re:明細の再確認 UO3 12/8/21(火) 17:48 発言[未読]
【72542】Re:明細の再確認 UO3 12/8/21(火) 20:40 発言[未読]
【72543】Re:明細の再確認 杏子 12/8/21(火) 21:14 お礼[未読]
【72544】Re:明細の再確認 杏子 12/8/21(火) 22:42 質問[未読]
【72546】Re:明細の再確認 UO3 12/8/22(水) 0:50 発言[未読]
【72548】Re:明細の再確認 杏子 12/8/22(水) 6:26 質問[未読]
【72549】Re:明細の再確認 UO3 12/8/22(水) 13:59 発言[未読]
【72551】Re:明細の再確認 杏子 12/8/22(水) 15:19 お礼[未読]

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

引用なし
パスワード
   手元にあるexcel資料(A)と実際手配を行った明細(B)の合致を確認するマクロの作成をしたいのですが、いいように思い浮かばなくて困っています。
皆さまのお知恵を貸してください。

■内容
1.concatenate関数で型名/数量/金額/納期/納地のデータを(A)と(B)でそれぞれ作成。
2.vlookup関数でデータの一致を確認する。

※(A)のデータを貼り付け、ボタンを押すだけで自動で再確認が行えるようなツールを作成したいです。
(A)(B)ともにセルA2からデータが入力されています。(1行目は項目が入力あり)

【72511】Re:明細の再確認
発言  UO3  - 12/8/18(土) 11:12 -

引用なし
パスワード
   ▼杏子 さん:

こんにちは

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

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

【72512】Re:明細の再確認
質問  杏子  - 12/8/18(土) 15:31 -

引用なし
パスワード
   ▼UO3 さん:

お返事が遅くなってしまい申し訳ありません。
ご回答ありがとうございました。

補足を忘れていたのですが、
それぞれの資料(A)(B)ともに型名/数量/金額/納期/納地の他に消費税などと言った必要のない項目が含まれておりU03さんに提示していただいたコードで実行すると
「以下の相違がありました
 A1(A)型名 vs (B)消費税
 B1(A)数量 vs (B)納期
 …
 …
 …」
とメッセージが出てきてしまいました。
必要な項目のみを抜き出しての確認は出来ないでしょうか。

【72515】Re:明細の再確認
発言  UO3  - 12/8/18(土) 20:54 -

引用なし
パスワード
   ▼杏子 さん:

>必要な項目のみを抜き出しての確認は出来ないでしょうか。

もちろんできますよ。
どの場所にあるものをチェックするということを教えてもらえれば。

【72516】Re:明細の再確認
発言  杏子  - 12/8/19(日) 13:12 -

引用なし
パスワード
   ▼UO3 さん:


お返事が遅くなってしまいました。

「どの場所にあるものをチェックするということを教えてもらえれば。」

の「場所」と言うのは資料(A)(B)が保存されている場所と言うことでしょうか。
両方ともにSドライブ配下に保存されています。

【72517】Re:明細の再確認
発言  UO3  - 12/8/19(日) 14:41 -

引用なし
パスワード
   ▼杏子 さん:

いやぁ・・そうではなく、資料(A)と資料(B)があるとして

1.まず、それぞれの資料は、どこにあるのか?
 これについては、今回、「両方ともにSドライブ配下に保存されています」ということですが
 最初の説明では、「※(A)のデータを貼り付け、ボタンを押す」とありましたね。
 Sドライブのこれら両方のブックのシートを「操作者」が、「どこか(たとえば、マクロブックのシート)」
 に貼り付けて、そこで比較するのか。説明では「(A)を貼り付け」とあったので、
 じゃぁ(B)は、貼り付けないのかとか、いやいや操作者ではなくボタンをおしたら、マクロでSドライブから
 ブックを自動で読み込んで「貼り付け(どのシートをどこに)」、比較を行うのか 等々
 杏子さんがイメージしている、処理のシナリオが見えないので、そこを説明して欲しいですね。
2.で、比較するのは、ブックではなくシート。どのシートとどのシートを比較するのか。
 (操作者が、事前に、マクロブックに取り込んでいるなら、マクロブックのシートの、どれが(A)なのか、どれが(B)なのか)
 これを明確にしていただかなければいけません。
3.そして、一番重要なことは、(A)のどの列と(B)のどの列を比較するのか?
 (特定の行だけを比較するなら行についても)
 どの列というのではなく、たとえば、それぞれのレイアウトは異なるけど、タイトルが 型名/数量/金額/納期/納地
 の列同士を比較、これ以外の列は比較しないとか。

このような情報が、コード案を回答する時には必須です。

で、「自動で再確認」ということは、具体的には、どのような確認にしたいのか?
アップしたコードでは相違の場所をメッセージで表示していますが、そうではなく、違っている一覧表を作りたいとか
違っているセルに色を塗りたいとか、それは、杏子さんが決めて、要件として説明しなきゃいけませんね。

【72518】Re:明細の再確認
発言  杏子  - 12/8/19(日) 15:02 -

引用なし
パスワード
   よく分かっていなくすみませんでした。

1&2.はじめに「※(A)のデータを貼り付けボタンを押す」と記載しましたが、
  1.sheet1にマクロ登録済ボタンを作成、sheet2に資料(A)のデータ、sheet3に資料(B)のデータを貼り付けます。そしてsheet1のボタンを押すとマクロが実行されるようにしたいです。

3.1行目の項目のタイトルが型名/数量/金額/納期/納地の入力コードをconcatenateでつなげて比較したいです。

【72520】Re:明細の再確認
発言  UO3  - 12/8/19(日) 16:15 -

引用なし
パスワード
   ▼杏子 さん:

う〜〜ん・・・・
こちらは、杏子さんの考えていることを透視できないわけで、
具体的に(めんどくさがらず)詳細な説明がほしかったんですがねぇ。
まぁ、この説明だけでコードを考えてみますが、きっと、
あぁ、そうじゃなく、こんな比較 とか、 そんな結果表示じゃなく、こんな結果表示が欲しい とか。
コードをアップしてから、いろいろ出てきそう?

>  1.sheet1にマクロ登録済ボタンを作成、sheet2に資料(A)のデータ、sheet3に資料(B)のデータを貼り付けます。そしてsheet1のボタンを押すとマクロが実行されるようにしたいです。

 ・資料(A)、資料(B)の貼付は、操作者がやるのですか?マクロがやるのですか?
 ・マクロがやるとしたら、ボタンは、貼り付け、比較の2つですか?
  それとも、貼り付けてそのまま比較の、ボタン1つですか?

>3.1行目の項目のタイトルが型名/数量/金額/納期/納地の入力コードをconcatenateでつなげて比較したいです。

 ・おのおのの列の値の比較ではなく、これら5つの値を連結した値での比較ですね?
 ・で、これらの列は、どこですか? それとも、タイトルをトリガーにしてマクロでどの列かを捜すのですか?
 (どちらでもできますけど)

●それと、資料(A)と資料(B)のデータの並びは同じですか?
 つまり、5行目なら5行目どおしを比較していいのですか?
 それとも、データの並びはA,B 異なっているのですか?

【72521】Re:明細の再確認
発言  杏子  - 12/8/19(日) 16:27 -

引用なし
パスワード
   ▼UO3 さん:

何度もすみません。。。

・資料(A)、資料(B)の貼付は、操作者がやるのですか?マクロがやるのですか?
→sheet2,sheet3へのデータの貼り付けはマクロではなく操作者が行います。

 ・で、これらの列は、どこですか? それとも、タイトルをトリガーにしてマクロでどの列かを捜すのですか?
→はい、タイトルをチェックすることで列を探してつなげたいです。

・それと、資料(A)と資料(B)のデータの並びは同じですか?
 つまり、5行目なら5行目どおしを比較していいのですか?
 それとも、データの並びはA,B 異なっているのですか?
→データの並びはA,B 異なっているものとしています。

【72523】Re:明細の再確認
発言  UO3  - 12/8/19(日) 17:25 -

引用なし
パスワード
   ▼杏子 さん:

はい、なんとか書いてみましょう。
ところで、一般的には「何かをつきあわせキーにして」比較をして
このキーについては(A)は●●●、一方、(B)は■■■
という相違を表示するんですが
今回は、5項目を連結したものがすべてつきあわせキーですから
5項目を連結した状態で (A)のみにあるものと、(B)のみにあるものが
相違ということなんですが、それで、意図通りですか?

【72524】Re:明細の再確認
発言  杏子  - 12/8/19(日) 17:32 -

引用なし
パスワード
   ▼UO3 さん:

はい、連結させたものでの比較で構いません。
よろしくお願いします。

【72525】Re:明細の再確認
発言  UO3  - 12/8/19(日) 17:34 -

引用なし
パスワード
   ▼杏子 さん:

ということで、とりあえず。
でも、杏子さんの意図は、ほんとにそうなのかなぁ?? と。

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(1 To 5) As Variant
  Dim colB(1 To 5) As Variant
  Dim shA As Worksheet
  Dim shB As Worksheet
  Dim c As Range
  
  
  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) Then Exit Sub
  If Not GetCol(shB, colB) 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) As Boolean
  Dim x As Long
  Dim ck As String
  Dim z As Variant
  For x = 1 To 5
    ck = Array("型名", "数量", "金額", "納期", "納地")(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 dKey As String
  For Each c In sh.Range("A2", sh.Range("A" & sh.Rows.Count).End(xlUp))
    dKey = c.Offset(, v(1) - 1).Value & "/" & _
        c.Offset(, v(2) - 1).Value & "/" & _
        c.Offset(, v(3) - 1).Value & "/" & _
        c.Offset(, v(4) - 1).Value & "/" & _
        c.Offset(, v(5) - 1).Value
    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

【72527】Re:明細の再確認
発言  杏子  - 12/8/19(日) 18:58 -

引用なし
パスワード
   ▼UO3 さん:

ありがとうございます。
自分が思っていた以上に長いコードだったので少しびっくりしました。

U03さんのコードで実行してみました。
    ck = Array("型名", "数量", "金額", "納期", "納地")(x - 1)
のところが実際確認したい項目は一部違っていたので名称を訂正しました。
    訂正後:ck = Array("型名", "数量", "合価", "構成GC")(x - 1)

すると「実行時エラー'9'インデックスが有効範囲にありません」
と出てきてしまいました。

あと、これはsheet1とsheet2にデータを貼り付けた場合ですよね。

【72528】Re:明細の再確認
発言  UO3  - 12/8/19(日) 19:17 -

引用なし
パスワード
   ▼杏子 さん:

チェックすべき列が 5 つという前提のコードです。

>訂正後:ck = Array("型名", "数量", "合価", "構成GC")(x - 1)

これでは、チェックすべきものが 4つしかないのに、そのArrayの中から
5つの項目を取り出そうとして、インデックスエラーになります。
この 5 つという数は、コードのあちこちで使っていますので、4 に
変更するにはだいぶ訂正する必要があります。

で、後ほど、訂正コードをアップしますが、その時には、チェックすべき項目数を
簡単に変更できるような構えにしますね。

ところで・・・
ほんとうにこれでいいのですか?
上で、コードで比較しているロジックについて簡単にふれましたが、
通常であれば、比較するキー(たとえば型名)について、(A),(B)の型名以外の項目が
同じかどうかという比較になりますよねぇ。
アップしたコードは(繰り返しになりますが)型名も含めた指定項目を連結したものが一方にしかない場合を
相違としてピックアップしています・・・

【72529】Re:明細の再確認
発言  杏子  - 12/8/19(日) 19:30 -

引用なし
パスワード
   ▼UO3 さん:

ご指摘ありがとうございます。
はい、それで構いません。

お手間を取らせてしまいすみませんがよろしくお願いします。

【72533】Re:明細の再確認
発言  杏子  - 12/8/20(月) 9:32 -

引用なし
パスワード
   ▼UO3 さん:

昨日の件出来ましたでしょうか。
急がせてしまい申し訳ありません。

【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

【72537】Re:明細の再確認
質問  杏子  - 12/8/21(火) 6:23 -

引用なし
パスワード
   ▼UO3 さん:

おはようございます。
お返事が遅くなり申し訳ありませんでした。

UO3さん記載のコードでうまくいきました。
ありがとうございます。
もう一つ付け加えをしたいのですが。。。

一致しなかった場合にメッセージで
「資料(A)のうち、以下が資料(B)にありません
 ○○○/▼▼▼/□□□」
と出てきますが、この時に対象のセルに赤く色付けすることは出来ないでしょうか。

【72538】Re:明細の再確認
質問  杏子  - 12/8/21(火) 10:37 -

引用なし
パスワード
   ▼UO3 さん:

もう一つお願いがあります。
今は「型名/数量/合価/構成GC」となっていますが、
「合価」の名称が「契約金額」となっていた場合に「合価」と置き換えて
処理を行えるようには出来ないでしょうか。
一方は「合価」、もう一方は「契約金額」ではマッチングは出来ないですよね。
頼りきりになってしまいすみません。。。

【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

【72540】Re:明細の再確認
質問  杏子  - 12/8/21(火) 12:14 -

引用なし
パスワード
   ▼UO3 さん:

何度も対応ありがとうございます。
一つ付け加えていいでしょうか。
資料(A)の金額欄が「合価/契約金額/金額」いづれの名称の場合でも対応可能にすることは出来ないでしょうか。

【72541】Re:明細の再確認
発言  UO3  - 12/8/21(火) 17:48 -

引用なし
パスワード
   ▼杏子 さん:

できますよ〜。
今日は、ちょっと野暮用あり。
コードアップは明日になります。

【72542】Re:明細の再確認
発言  UO3  - 12/8/21(火) 20:40 -

引用なし
パスワード
   ▼杏子 さん:

こんばんは

野暮用がが早く片付いたのでコードを書きました。
ややこしくなるので一式、アップします。すべていれかえてください。

なお、

  vntTitleA = Array("型名", "数量", "合価|契約金額|金額", "構成GC")
  vntTitleB = Array("型名", "数量", "契約金額", "構成GC")

これで資料Aと資料Bの、それぞれ対になるタイトルを規定しますが、可能性として複数あるものは
資料Aであれ資料Bであれ、また、どのタイトル項目であれ、"●●|■■|△△|□□" といったように
| で区切って指定します。
また、上記例では、比較列は4組ですが、必要なだけ何組でも記述可能です。

Sub Sample4()
  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 Long
  Dim headStr As String
  Dim w As Variant
  Dim wStr As String
  Dim n As Long
  
  
  headStr = vbTab & Join(WorksheetFunction.Index(sh.Range("A1", sh.Cells(1, sh.Columns.Count).End(xlToLeft)).Value, 1, 0), vbTab) & vbTab
  
  With CreateObject("VBScript.RegExp")
    x = UBound(vntT) + 1
    For x = 1 To x
      ck = vntT(x - 1)
      .Pattern = vbTab & "(" & ck & ")" & vbTab
      With .Execute(headStr)
        If .Count = 0 Then
          z = 0
        Else
          n = .Item(0).firstindex + 1
          wStr = Left(headStr, n)
          z = Len(wStr) - Len(Replace(wStr, vbTab, ""))
        End If
      End With
      
      If z = 0 Then
        MsgBox sh.Name & "のタイトル行に" & ck & "がないので処理を終了します"
        Exit Function
      End If
      v(x) = z
      sh.UsedRange.Columns(z).Interior.ColorIndex = xlNone
    Next
  End With
  
  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

【72543】Re:明細の再確認
お礼  杏子  - 12/8/21(火) 21:14 -

引用なし
パスワード
   ▼U03さん

出来ました!
本当にありがとうございます!!
私のわがままで何度も手直ししていただき本当に助かりました。

自分でもこんなプログラムが作成できるようこれからも勉強がんばります。

【72544】Re:明細の再確認
質問  杏子  - 12/8/21(火) 22:42 -

引用なし
パスワード
   ▼U03さん

お礼を言って終わった後にすみません。。。

提示してくださったコードの中で要となるような所だけで結構なので
「'」で説明をつけてもらえないでしょうか。
明日会社のみなさんに軽く説明をしたいので。。。

お願い出来ますでしょうか。

【72546】Re:明細の再確認
発言  UO3  - 12/8/22(水) 0:50 -

引用なし
パスワード
   ▼杏子 さん:

こんばんは

明日、説明ですかぁ!
このコードは、コードに説明をつけても、それだけではわかりづらいところがあるかもです。
Dictionary や 正規表現 といった、エクセルVBA標準ではない外部ライブラリーの機能を使っていますので
そのあたりがわからないと、ちんぷんかんぷんかもしれません。
また、これは、そんなに難しくはないでしょうけど、処理の大部分を、Functionプロシジャやsubプロシジャを
サブルーティンとして用意して、それらを使うような構成です。
でも、ここの部分も、もし、詳しくないなら、なんじゃらほい? と悩まれるかも。

むしろ、ここがわからないということを杏子さんのほうから質問してもらえれば、そこに的を絞って
解説をさしあげるというほうがいいような気がするのですが?

それにしても、明日・・・むむむ・
もう、遅いのでおねむの時間ですし、明日は朝から夕方まで、あれやこれやと気ぜわしいスケジュールで
このコード全体にコメントをつける時間がとれない公算が大きいですねぇ・・・



【72548】Re:明細の再確認
質問  杏子  - 12/8/22(水) 6:26 -

引用なし
パスワード
   ▼UO3 さん:

おはようございます。
そうですよね。。。こんなに長いコードから絞り込むのは難しいですよね。
無理を言ってしまいすみませんでした。

ではここだけでもよろしいでしょうか。

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

ここと

headStr = vbTab & Join(WorksheetFunction.Index(sh.Range("A1", sh.Cells(1, sh.Columns.Count).End(xlToLeft)).Value, 1, 0), vbTab) & vbTab
  
  With CreateObject("VBScript.RegExp")
    x = UBound(vntT) + 1
    For x = 1 To x
      ck = vntT(x - 1)
      .Pattern = vbTab & "(" & ck & ")" & vbTab
      With .Execute(headStr)
        If .Count = 0 Then
          z = 0
        Else
          n = .Item(0).firstindex + 1
          wStr = Left(headStr, n)
          z = Len(wStr) - Len(Replace(wStr, vbTab, ""))
        End If
      End With
      
      If z = 0 Then
        MsgBox sh.Name & "のタイトル行に" & ck & "がないので処理を終了します"
        Exit Function
      End If
      v(x) = z
      sh.UsedRange.Columns(z).Interior.ColorIndex = xlNone
    Next
  End With
  
  GetCol = True
  
End Function


ここだけでも。全体ではなく大切な所だけで結構ですので。。。
よろしくお願いします。

【72549】Re:明細の再確認
発言  UO3  - 12/8/22(水) 13:59 -

引用なし
パスワード
   ▼杏子 さん:

こんにちは

コードのコメントというより、コード処理の解説文章になって見づらいとは思うけど。


  '以下変数で、○○A は資料A用変数 ○○B は資料B用変数

  Dim dicA As Object   '資料Aの比較セルの値を連結したものをキー、行番号をデータとする辞書
  Dim dicB As Object   '資料Bの比較セルの値を連結したものをキー、行番号をデータとする辞書
  Dim dicAonly As Object '資料Aにあって資料Bにないものの資料Aの行番号をキーとした辞書
  Dim dicBonly As Object '資料Bにあって資料Aにないものの資料Bの行番号をキーとした辞書
  Dim d As Variant
  Dim colA() As Variant  '資料Aの比較列の列番号が必要列数格納されている1次元配列
  Dim colB() As Variant  '資料Bの比較列の列番号が必要列数格納されている1次元配列
  Dim shA As Worksheet  '資料A シートオブジェクト
  Dim shB As Worksheet  '資料B シートオブジェクト
  Dim c As Range
  Dim vntTitleA As Variant  '資料Aの比較列のタイトルが必要数格納されている1次元配列
  Dim vntTitleB As Variant  '資料Bの比較列のタイトルが必要数格納されている1次元配列

Private Function GetCol(sh As Worksheet, v As Variant, vntT As Variant) As Boolean
  '資料A,資料B 共通サブプロシジャ
  'Call GetCol(shA, colA, vntTitleA) このように呼び出される
  '呼び出される際の引数は以下の通り。
  'sh  資料シート
  'v   このプロシジャで比較列の列番号を格納して返す次元配列
  'vntT 比較列のタイトルが格納されている1次元配列
  
  'プロシジャの機能
  ' 比較必要タイトルの資料上の実際の列番号を引数でわたされた ColA あるいは ColB に納める。
  ' 戻り値は 通常は True。もし、資料のタイトルに設定されたタイトルがなければFalse。
  
  Dim x As Long
  Dim ck As String
  Dim z As Long
  Dim headStr As String
  Dim w As Variant
  Dim wStr As String
  Dim n As Long
 
  headStr = vbTab & Join(WorksheetFunction.Index(sh.Range("A1", sh.Cells(1, sh.Columns.Count).End(xlToLeft)).Value, 1, 0), vbTab) & vbTab
 
  '上記コードを分解して説明
  
  'sh.Range("A1", sh.Cells(1, sh.Columns.Count).End(xlToLeft)).Value
  '資料シートの1行目のタイトル行領域
  'したがって
  'WorksheetFunction.Index(sh.Range("A1", sh.Cells(1, sh.Columns.Count).End(xlToLeft)).Value, 1, 0)
  'これは
  'WorksheetFunction.Index(資料シートの1行目のタイトル行領域, 1, 0)
  
  'Index関数は (対象配列または領域,指定行,指定列)
  'で、行または列に0 を指定すると行全体あるいは列全体が抽出されて配列におさめられる。
  'なので、WorksheetFunction.Index(資料シートの1行目のタイトル行領域, 1, 0) は
  '資料シートの1行目のタイトル行領域 の 1行目 という、はなはだ変な処理。
  'なにをしているかというと、資料シートの1行目のタイトル行領域 は 1行複数列の 2次元配列。
  'これを、このコードを実行することで1次元配列に変換してる。(Join関数は1次元配列しかサポートしないので)
  
  'なので、
  'Join(WorksheetFunction.Index(sh.Range("A1", sh.Cells(1, sh.Columns.Count).End(xlToLeft)).Value, 1, 0), vbTab)
  'これは
  'Join(資料シートの1行目のタイトル行領域を1次元配列にしたもの, vbTab)
  'これはこのタイトル領域の各セルを vbTab(特殊なコード)で連結したもの。
  'たとえば ○○vbtab◆◆vbtab▼▼vbtab□□・・・・ という文字列になる。
  
  'で、headStr = vbTab & ○○vbtab◆◆vbtab▼▼vbtab□□・・・・& vbTab なので
  'headStr は最終的に vbTab○○vbtab◆◆vbtab▼▼vbtab□□・・・・vbTab となる。
  
  '以下 正規表現(RegExp)機能を使う。
  '正規表現は文字列に対して【ワイルドカードのお化け】のようなパターンを与えて
  'そのパターンが文字列中に存在するかどうか、存在していれば、文字列のどこの位置にあったか
  '瞬時にチェックしてくれる優れもの。
  
  With CreateObject("VBScript.RegExp")
    x = UBound(vntT) + 1  'タイトル規定の配列の要素数(指定タイトル数)
    For x = 1 To x     'タイトル規定配列から設定タイトルを抽出するループ
      ck = vntT(x - 1)  'ck に指定タイトル文字列をいれる。
                'なので ck は 数量 あるいは 合価|契約金額|金額 という文字列になる。
      .Pattern = vbTab & "(" & ck & ")" & vbTab
                'チェック文字列のパターン
                'vbTab(数量)vbtab  これは vbTab数量vbTab という文字列をさがすというパターン
                ''vbTab(合価|契約金額|金額)vbtab  これは
                'vbTab合価vbTab または vbTab契約金額vbTab または vbTab金額vbTab が対象。
      With .Execute(headStr) '上で説明した headStr の文字列の中からパターンにあるものをピックアップ
        If .Count = 0 Then 'パターンがなかった?
          z = 0
        Else
          n = .Item(0).firstindex + 1 'FristIndexは【0】から始まる文字列内の位置
          wStr = Left(headStr, n)   '見つかった数量等の前までの文字列をwStrに抜き出す
          z = Len(wStr) - Len(Replace(wStr, vbTab, ""))
            'この 数量 が B列(2列目)だとするとwstrには、vbTab が 2個ある。
            'なので、wStr の桁数 と wStrから vbTab を取り去った桁数の差が
            'このタイトルが何列目なのかという値。(わかるかなぁ・・・)
        End If
      End With
   
      If z = 0 Then
        MsgBox sh.Name & "のタイトル行に" & ck & "がないので処理を終了します"
        Exit Function    'ここで抜けるので戻り値は False のまま。
      End If
      v(x) = z    '上記で取得した値(資料上の実際の列番号)を ColA ないしは ColB の外套の位置に格納
      'その列の背景色を、いったん消す。
      sh.UsedRange.Columns(z).Interior.ColorIndex = xlNone
    Next
  End With
 
  GetCol = True  '戻り値を True にする。
 
End Function

【72551】Re:明細の再確認
お礼  杏子  - 12/8/22(水) 15:19 -

引用なし
パスワード
   ▼UO3 さん:

解説拝見しました。
一行ずつ解説していただき助かりました。

明日発表しようと思いますのでそれまで熟読して理解を深めようと思います。
この度は本当にありがとうございました。

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