Board logo

標題: [發問] 如何利用VBA一鍵 自動比對工作表A & B的C欄相異號碼？ [打印本頁]
作者: RCRG    時間: 2015-11-12 11:33     標題: 如何利用VBA一鍵 自動比對工作表A & B的C欄相異號碼？

本帖最後由 RCRG 於 2015-11-12 11:35 編輯

[attach]22415[/attach]

[attach]22419[/attach]
[attach]22418[/attach]
作者: lpk187    時間: 2015-11-12 14:22

本帖最後由 lpk187 於 2015-11-12 14:28 編輯

回復 1# RCRG
Msgbox的最大字元多少，不知道，不過依VBE說明:最大長度大約是1024個字元，由使用字元的寬度決定。如果 prompt 超過一行，您可以在每一行之間用復位字元(Chr(13))、換行字元 (Chr(10)) 或是復位字元與換行字元的組合 (Chr(13) & Chr(10)) 來做區隔。
是不是換行後可以增加，不確定。請自行參考VBE說明
  1. Sub 按鈕1_Click()
  2. Dim Rng As Range
  3. With Sheets("B")
  4.     For Each Rng In .Range("C2:CC1000")
  5.         If Rng <> "" Then
  6.             Set da = Sheets("A").Range("c3:c79").Find(Rng.Value, LookAt:=xlWhole, SearchDirection:=2)
  7.             If da Is Nothing Then
  8.                 aa = aa & Rng.Value & ","
  9.             Else
  10.                 Set da = Nothing
  11.             End If
  12.         End If
  13.     Next
  14.     aa = Left(aa, Len(aa) - 1)
  15.     MsgBox aa
  16. End With
  17. End Sub
複製代碼
作者: RCRG    時間: 2015-11-12 16:08

本帖最後由 RCRG 於 2015-11-12 16:10 編輯

回復 2# lpk187


    　謝謝lpk187大的解答，完全符合我所要的(C2:C1000範圍錯了，我自行修正了)；
對了，Msgbox我如果前面要在加些中文 "相異號碼如下：L777779,L787878C,L989598"，這樣要如何修改呢?
作者: lpk187    時間: 2015-11-12 18:16

回復 3# RCRG


    MsgBox "相異號碼如下：" & aa
作者: RCRG    時間: 2015-11-13 12:03

回復 2# lpk187


    發現一個異常，就是如果工作表B的C欄位沒資料可以比對的話，會彈出一個錯誤視窗呢，能把空白內容視為正常嗎?
作者: 准提部林    時間: 2015-11-13 12:25

Sub TEST()
Dim MH, ST, TT$
For Each ST In [B!C2:C1000]
　　MH = 0
　　If ST <> "" Then MH = Application.Match(ST, [A!C2:C79], 0)
　　If IsError(MH) Then TT = TT & "," & ST
Next
If TT <> "" Then MsgBox "相異號碼如下：" & Mid(TT, 2)
End Sub
作者: RCRG    時間: 2015-11-14 03:58

回復 6# 准提部林

1. 如果我要再多比對一個工作表C(但範圍只有到C2:C500)，我自行隨便亂修改如下應該沒問題吧(我自己測試起來是OK啦QQ)
2. 另外相異的號碼如果是一樣的可以只顯示一個嗎?如果有兩個L123456，彈出視窗就會跑L123456,L123456這樣，而我只想跑一個出來就好。
3. 如果比對的工作表B沒有內容或沒有相異號碼，按下去雖然不會有偵錯視窗了，但似乎也沒有任何視窗出現提醒，會讓人誤以為有在比對嗎?不知能否幫我彈出 "資料正常" 的彈出視窗字眼。


    Sub TEST()
Dim MH, ST, TT$
For Each ST In [B!C2:C1000]
　　MH = 0
　　If ST <> "" Then MH = Application.Match(ST, [A!C2:C79], 0)
　　If IsError(MH) Then TT = TT & "," & ST
Next

For Each ST In [C!C2:C500]
　　MH = 0
　　If ST <> "" Then MH = Application.Match(ST, [A!C2:C79], 0)
　　If IsError(MH) Then TT = TT & "," & ST
Next
If TT <> "" Then MsgBox "相異號碼如下：" & Mid(TT, 2)

End Sub
作者: 准提部林    時間: 2015-11-14 11:20

本帖最後由 准提部林 於 2015-11-14 11:24 編輯

回復 7# RCRG


For Each ST In [B!C2:C1000]
　　MH = 0
　　If ST <> "" Then MH = Application.Match(ST, [A!C2:C79], 0)
　　If IsError(MH) Then
　　　　If InStr("," & TT & ",", "," & ST & ",") = 0 Then TT = TT & "," & ST
　　End If
Next
If TT = "" Then MsgBox "無相異" Else MsgBox "相異號碼如下：" & Mid(TT, 2)

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
１．InStr("," & TT & ",", "," & ST & ",")
　　比對文字要以〔逗號〕前後包覆，否則以 L111222 比對 L111222A 會誤判！
　　以 ,L111222, 比對 ,L111222A, 就沒問題∼這與使用 Find 函數同理∼
　
２．If TT = "" Then MsgBox "無相異" Else MsgBox "相異號碼如下：" & Mid(TT, 2)
　　If ~~ Then ~~ Else ~~, 這是最簡單基本的判斷

若學 excel 已有一段時間， 上面的程式碼應都可以理解的！
作者: yen956    時間: 2015-11-14 15:44

試試看:
1. 插入UserForm1, 並設定 Caption 的屬性為"比對結果"
2. 在 UserForm1 中插入 Label1, ListBox1 及 CommandButton1
3. 設定 UserForm1.CommandButton1 的 Caption 屬性為"確定"
4. Double Click UserForm1.CommandButton1, 在編輯視窗中鍵入下列 VBA code:
  1. Private Sub CommandButton1_Click()
  2.         Unload Me
  3.     End Sub
複製代碼
5. 離開VBA編輯視窗回到 sheetA, 在 sheetA 中插入CommandButton1,
    並設定 Caption 的屬性為"按我比對"
6. Double Click CommandButton1, 在編輯視窗中鍵入下列 VBA code:
  1. Private Sub CommandButton1_Click()
  2.     Dim rngA As Range, rngB As Range, rngC As Range
  3.     Dim cel As Range, foundCel As Range
  4.     Dim cntLB As Integer, R As Integer
  5.     Set rngA = [A!C3:C79]
  6.     Set rngB = [B!C3:C1000]
  7.     Set rngC = [C!C3:C500]
  8.     '
  9.     '先比對rngB 及rngC, 並將相異號碼存到暫存區[B!D:D]
  10.     '再重設 rngB, 進而比對rngB 及rngA
  11.     '
  12.     UserForm1.ListBox1.Clear       '清除ListBox
  13.     [B!D:D] = ""     '清除暫存區
  14.     R = 1
  15.     For Each cel In rngC
  16.         If cel <> "" Then
  17.             Set foundCel = rngB.Find(cel, LookAt:=xlWhole, SearchDirection:=2)
  18.             
  19.             'foundCel Is Nothing 表示沒找到, 即 rngC的cel 與 rngB 不重覆
  20.             If foundCel Is Nothing Then
  21.                 R = R + 1
  22.                 Sheets("B").Cells(R, 4) = cel '將 rngC的cel 加到 暫存區
  23.             End If
  24.         End If
  25.     Next
  26.    
  27.     Set rngB = [B!C3:D1000]      '再重設 rngB
  28.     For Each cel In rngB
  29.         If cel <> "" Then
  30.             Set foundCel = rngA.Find(cel, LookAt:=xlWhole, SearchDirection:=2)
  31.             
  32.             'foundCel Is Nothing 表示沒找到, 即 rngB的cel 與 rngA 不重覆
  33.             If foundCel Is Nothing Then
  34.                 UserForm1.ListBox1.AddItem cel    '將 rngB的cel 加到 ListBox1
  35.             End If
  36.         End If
  37.     Next
  38.     cntLB = UserForm1.ListBox1.ListCount
  39.     If cntLB = 0 Then
  40.         MsgBox "找不到相異號碼!!", vbCritical
  41.     Else
  42.         UserForm1.Label1.Caption = "共有" & cntLB & "筆相異號碼," & Chr(10) _
  43.                  & "如下所列："
  44.         UserForm1.Show
  45.     End If
  46. End Sub
複製代碼
[attach]22445[/attach]
作者: RCRG    時間: 2015-11-17 07:02

回復 8# 准提部林


    謝謝准大再次解題，讓見笑了...XD
作者: GBKEE    時間: 2015-11-17 09:02

回復 10# RCRG
試試看 VBA 還有其它語法可寫
  1. Option Explicit
  2. Sub EX()
  3.     Dim Rng, AR, T, E
  4.     Rng = Array([A!C3:C79], [B!C2:C79]) '[C!C2:C79],[D!C2:C79],[E!C2:C79].....可加入許多範圍
  5.     For Each E In Rng
  6.         AR = Application.Transpose(E.Value)
  7.         T = T & "," & Join(AR, ",")
  8.     Next
  9.     AR = Split(T, ",")
  10.     T = ""
  11.     For Each E In AR
  12.         If E <> "" Then
  13.         'Filter 函數 傳回一個從零開始的陣列，該陣列包含基於指定篩選準則的一個字串陣列的子集。        '
  14.            If UBound(Filter(AR, E, True)) = 0 Then '陣列裡只有一個元素
  15.                 T = T & IIf(T <> "", ",", "") & E
  16.            End If
  17.         End If
  18.     Next
  19.     If T <> "" Then
  20.         T = "相異號碼如下：" & vbLf & Replace(T, ",", vbLf)
  21.     Else
  22.         T = "查無相異號碼"
  23.     End If
  24.     MsgBox T
  25. End Sub
複製代碼
作者: 准提部林    時間: 2015-11-17 15:27

借用超板的〔陣中陣〕：
Sub TEST()
Dim xD, SS, S
Set xD = CreateObject("Scripting.Dictionary")
For Each SS In Array([B!C2:C1000], [C!C2:C1000])
For Each S In SS
　　If S <> "" And Not xD.Exists(S & "") Then xD(S & "") = ""
Next: Next
For Each S In [A!C3:C79]
　　If xD.Exists(S & "") Then xD.Remove S & ""
Next
If xD.Count Then MsgBox "相異號碼如下：" & Join(xD.keys, ",") Else MsgBox "無相異"
End Sub



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)