麻辣家族討論版版 - Powered by Discuz! Board

標題: 請問各位大神這段VBA 比對有0開頭的文字如何比對的到? [打印本頁]

作者: jeffrey628litw 時間: 2019-12-24 18:33 標題: 請問各位大神這段VBA 比對有0開頭的文字如何比對的到?

請問各位大神這段VBA Module 8 比對有0開頭的文字如何比對的到?

1.這是從工作表設比對條件清單中 A 欄
比對工作表 OE No後資料  撈出

問題：0310480000 有 0在最前面的會無法和工作表  設比對條件清單  A 欄比對後出現在
這裡的A欄下面

2.這裡應該出現比對後重複的資料  0310480000
但是沒出現

請問 VBA Module 8 裡面程式要如何修改呢?

[attach]31578[/attach]

設比對條件清單

[attach]31579[/attach]

VBA Module 8 程式碼：
Sub 開始比對不重複()

Dim t1

t1 = Timer '這是產生秒數的 MSG

'==============================================================
'以下為將過濾單一儲存格雙條件重複清單先貼過來試跑看看

Dim Ar(32)

Sheets("設比對條件清單").Select
Sheets("設比對條件清單").Name = "Sheet1"

Set d = CreateObject("Scripting.Dictionary")
With Sheet1

For Each a In .Range(.[A2], .[A101].End(xlUp))



  For i = 0 To 1
Ar(i) = a.Offset(, i).Value
Next i
d(a & "") = Ar


Next
End With

Range("a1").Parent.Name = "設比對條件清單"

Sheets("比對後重複清單").Select
Sheets("比對後重複清單").Name = "Sheet2"


'==============================================================

  '刪除  D 欄為0時的儲存格公式資料

Range("D2").Select

   For X = 1 To 1
   For y = 2 To 101

   If ActiveCell(y, X) = 0 Then

      ActiveCell(y, X) = ""

   Else

   End If


   Next y

   Next X


'==============================================================

With Sheet2

For Each a In .Range(.[D2], .[D101].End(xlUp))
For Each ky In d.keys
   If InStr(a, ky) > 0 Then a.Offset(, -3).Resize(, 1) = d(ky): Exit For
Next
Next

End With

Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D101"), Type:=xlFillDefault
Range("D2:D101").Select

Range("D2").Select

Range("a1").Parent.Name = "比對後重複清單"


'==============================================================

Sheets("比對後重複清單").Select

ROW1 = Cells(Rows.Count, "C").End(3).Row

'下面3列程式是如果要撈出2欄以上資料需開放的程式碼

' If ROW1 > 2 Then
'    Range(Cells(1, "C"), Cells(ROW1, "E")).Clear
' End If

'==============================================================

ROW1 = Cells(Rows.Count, "A").End(3).Row

arr = Range("A2:A" & ROW1)

ROW2 = Sheets("設比對條件清單").Cells(Rows.Count, "A").End(3).Row

  '如果要撈出2欄以上資料需開放的程式碼，2欄 Range("A1:A" & ROW2) 要改成 Range("A1:B" & ROW2)

Sheets("設比對條件清單").Range("A1:A" & ROW2).AdvancedFilter _
      Action:=xlFilterCopy, CriteriaRange:=Range("A1:A" & ROW1), CopyToRange:=Range( _
      "C1:C1"), Unique:=False

      '上面的 "C1:C1" 為從資料庫撈出比對後資料，顯示在此工作表 C1:C1

'==============================================================

Sheets("比對後重複清單").Range("A:A").NumberFormatLocal = "@"  '加入這一行, 設為[文字]格式
Sheets("比對後重複清單").Range("C:C").NumberFormatLocal = "@"  '加入這一行, 設為[文字]格式
Sheets("比對後重複清單").Range("D:D").NumberFormatLocal = "@"  '加入這一行, 設為[文字]格式

'==============================================================

Columns("C:C").ColumnWidth = 28
Columns("D:D").ColumnWidth = 32

'==============================================================

'以下是生成不重複項目  的工作表

Sheets.Add After:=Sheets(Sheets.Count)
'Sheets(Sheets.Count).Name = "未比對到清單"

Columns("A:A").ColumnWidth = 28
Columns("B:B").ColumnWidth = 16

Cells(1, 3).Formula = "● 此是[未比對到]清單"
Cells(1, 3).Font.Color = RGB(43, 20, 134)
Cells(1, 3).Font.Bold = True
Cells(1, 6).Formula = "● 使用過後可刪除此工作表"
Cells(1, 6).Font.Color = RGB(128, 13, 32)
Cells(1, 6).Font.Bold = True

Sheets("設比對條件清單").Range("A1:A" & ROW2).Copy Range("A1")

For i = ROW2 To 2 Step -1

      For j = 1 To UBound(arr)
         If Cells(i, "A") Like arr(j, 1) Then
            Rows(i).Delete
            GoTo 1100
         End If
      Next

1100:

      Next

'==============================================================


'以下為讓產生  工作表不重複項目    的A1儲存格產生名稱

With Selection.Validation
      .Delete
      .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
      :=xlBetween
      .IgnoreBlank = True
      .InCellDropdown = True
      .InputTitle = ""
      .ErrorTitle = ""
      .InputMessage = ""
      .ErrorMessage = ""
      .IMEMode = xlIMEModeNoControl
      .ShowInput = True
      .ShowError = True
End With

'======================================================

'以下為顯示VBA Run程式的時間

MsgBox "抓資料完成!  " & Chr(10) & "使用時間：" & Round(Timer - t1, 2) & " 秒" & Chr(10) & "未比對到的資料，共計有" & "  " & Application.CountA(ActiveSheet.Columns("A:A")) - 1 & "  " & "筆"

'MsgBox "抓資料完成!  " & Chr(10) & "使用時間：" & Round(Timer - t1, 2) & " 秒" 這是產生秒數的 MSG
'==============================================================

End Sub

檔案下載：[attach]31580[/attach]

作者: jeffrey628litw 時間: 2019-12-25 18:49

回復 1# jeffrey628litw

不好意思檔案請改用這個試試看會比較快，大家耶誕節快樂

檔案下載：[attach]31584[/attach]

作者: jeffrey628litw 時間: 2019-12-26 17:11

不好意思，我發現在工作表比對重複清單的A欄，經儲存格式改文字就可以了。

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