[發問] 資料比對後填入相應資料以及公式

agietron

[attach]33163[/attach]
各位先進們好
第一次上論壇發問，如有禮貌不周請海涵
在下用我有限知識寫的VBA，
原始資料將近300個活頁(活頁還會繼續增加)，比對時經常會有幾百筆資料，
因此在作比對資料的時候所需時間很長
因此，上來提問，希望可以增進用VBA處理資料的能力
希望先進們幫忙
如範例檔案中的如範例檔案中的"工作表1"內的"O欄"為要查詢的資料項目
巨集"Sub SEARCH_aLL()"內容希望麻煩先進們協助改進
謝謝各位

軒云熊

回復 1# agietron

請問 agietron 大大  這公式 是加總甚麼?
Sheets(Sh).Cells(VR, 10).Formula = "=sum(i" & VR & "*h" & VR & ")"
是不是 i欄 * H欄  ?
可否說明一下  感謝

agietron

回復 2# 軒云熊
熊大
謝謝您關切
該算式是計算"工作表1"內的工作表1"內的"I"欄位*"H"欄位
預先填入公式為了方便填入數量後算出小記金額用的
勞駕您了真感謝您

准提部林

回復 1# agietron


把需求規則及流程說清楚,
別人無法用你的程式去解讀~~

agietron

用"工作表1"O欄內容比對工作表P39-P139的內容後，提取比對成功的工作表欄位資訊，製作出隨附檔案執行後內容
比對前:

下載 (105.57 KB)

2021-4-5 13:48

比對後:

下載 (139.71 KB)
比對後

2021-4-5 13:49

軒云熊

回復 5# agietron

有空幫我試試看 是不是你要的 但我不確定是不是正確 因為我的結果跟你的結果不一樣  而且迴圈也比較多 看看有沒有大大願意幫忙

1. Public Sub 跨工作表比對練習()
   
2. Application.ScreenUpdating = False
   
3. [A:K].ClearContents
   
4. Set xD = CreateObject("Scripting.Dictionary")
   
5. Brr = Range([工作表1!O65535].End(3), [工作表1!O1])
   
6. For X = 1 To UBound(Brr, 1)
   
7.     xD(Brr(X, 1)) = ""
   
8. Next X
   
9. DSC = InputBox("輸入折扣%", "折扣", "60")
   
10. For E = 1 To Sheets.Count - 1
    
11.     Arr = Sheets(E).UsedRange
    
12.     For X = 2 To UBound(Arr, 1)
    
13.         For Y = 1 To UBound(Arr, 2)
    
14.             If Arr(X, 1) <> "" And Len(Arr(X, Y)) > 7 And xD.exists(Arr(X, Y)) Then
    
15.                 With Sheets("工作表1")
    
16.                     K = K + 1: N = ""
    
17.                     Select Case Left(Arr(X, Y), 1)
    
18.                         Case "C"
    
19.                             G = "S220"
    
20.                         Case "M"
    
21.                             G = "M520"
    
22.                         Case "M"
    
23.                             G = "N620"
    
24.                         Case "N"
    
25.                             G = "S220焊接"
    
26.                         Case "A"
    
27.                             G = "HSS"
    
28.                         Case "H"
    
29.                             G = "HSS-Co"
    
30.                         Case "S"
    
31.                             G = "SKH"
    
32.                     End Select
    
33.                     xD.Remove (Arr(X, Y))
    
34.                     For S = 1 To 6
    
35.                         If Arr(2, S) <> "" Then N = N & Arr(2, S) & Arr(X, S) & " * "
    
36.                     Next S
    
37.                     Range("A" & K) = K
    
38.                     Range("B" & K) = G
    
39.                     Range("C" & K) = Arr(1, 1) & "-" & Sheets(E).Name & "-" & " " & "第" & X & "列" & Chr(10) & Mid(N, 1, Len(N) - 3)
    
40.                     Range("I" & K) = WorksheetFunction.Round(((Arr(X, Y + 1) * DSC) / 100), -1)
    
41.                     Range("J" & K).Formula = "=sum(i" & K & "*h" & K & ")"
    
42.                     Range("K" & K) = Arr(X, Y)
    
43.                 End With
    
44.             End If
    
45.         Next Y
    
46.     Next X
    
47. Next E
    
48. Application.ScreenUpdating = True
    
49. End Sub

複製代碼

0405.rar (141.9 KB)

下載次數: 10

2021-4-5 23:05

agietron

回復 6# 軒云熊


非常感謝   軒云熊大大，
完全符合我的期待，速度上也快了許多，
程式碼的部分我會好好鑽研，
原先需要約8秒的工作目前縮減到約兩秒鐘
非常感謝您的協助。

jcchiang

回復 1# agietron

我也來練習一下,試試看
Sub ex()
Dim arr As Variant, a As Variant, b As Variant
Dim d As Object, x%, y%, DSC%
Set d = CreateObject("scripting.dictionary")
DSC = InputBox("輸入折扣%", "折扣", "60")
With Sheets("工作表1")
   With .Range(.[a1], [k1].End(4))
      .Borders.LineStyle = xlLineStyleNone
      .UnMerge
      .ClearContents
   End With
   For Each a In .Range(.[O1], .[O1].End(4))
      If Not d.exists(a.Value) Then d(a.Value) = ""
   Next
End With
For x = 1 To Sheets.Count - 1
   With Sheets(x)
      For Each a In .UsedRange
         If d.exists(a.Value) Then
            For Each b In Array(Array("C", "S220"), Array("M", "M520"), Array("N", "N620"), Array("A", "S220焊接"), Array("H", "HSS"), Array("K", "HSS-Co"), Array("S", "SKH"))
               If b(0) = Left(a.Value, 1) Then d(a.Value) = b(1): Exit For
            Next
            arr = Array(.[a1] & "--" & .Name & "第" & a.Row & "列", Chr(10))
            For y = 1 To .[a2].End(2).Column
               ReDim Preserve arr(0 To UBound(arr) + 1)
               arr(UBound(arr)) = .Cells(2, y) & "*" & .Cells(a.Row, y) & " "
            Next
            d(a.Value) = Array(d(a.Value), Join(arr, ""), "", "", "", "", "", "=Roundup((" & a.Offset(, 1).Value & " * " & DSC / 100 & "), -1)", "", a.Value)
         End If
      Next
   End With
Next
With Sheets("工作表1")
   .[b1].Resize(d.Count, 10) = Application.Transpose(Application.Transpose(d.items))
   With .Range([a1], [k1].End(4))
      For x = 1 To .Rows.Count
         .Cells(x, 1) = x
         .Cells(x, 3).Resize(, 5).Merge
         .Cells(x, 10) = "=Sum(I" & x & "*H" & x & ")"
      Next
      .Borders.LineStyle = xlContinuous
   End With
End With
End Sub

agietron

回復 8# jcchiang
非常感謝jcchiang大大的協助，給了另一種方式解決問題，更感謝也順道幫忙把跨欄都做好了。
現在想增加一個功能，就是把"O"欄內比對不成功的儲存格文字變成紅色，該加那些語句呢?煩請您告知，感謝您！

samwang

回復 9# agietron

請測試看看，謝謝。

Sub TEST()
Dim Arr, Brr, xD, Frr(1 To 10000, 1 To 11), T, T1, TT, i&, j&, DSC%, sht%, y%, K%
Set xD = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
DSC = InputBox("輸入折扣%", "折扣", "60")
TM = Timer
Arr = Range([工作表1!O1], [工作表1!O65535].End(3))
For i = 1 To UBound(Arr)
    xD(Arr(i, 1) & "") = i
    If Right(Arr(i, 1), 1) <> "A" Then
        xD(Arr(i, 1) & "A" & "") = i
    End If
Next

For sht = 1 To Sheets.Count - 1
    Brr = Sheets(sht).UsedRange
    For i = 2 To UBound(Brr)
        For j = 1 To UBound(Brr, 2)
            If xD.Exists(Brr(i, j) & "") Then
                K = K + 1: TT = "": T = Left(Brr(i, j), 1)
                If T = "C" Then
                    T1 = "S220"
                ElseIf T = "M" Then
                    T1 = "M520"
                ElseIf T = "N" Then
                    T1 = "N620"
                ElseIf T = "A" Then
                    T1 = "S220焊接"
                ElseIf T = "H" Then
                    T1 = "HSS"
                ElseIf T = "K" Then
                    T1 = "HSS-Co"
                ElseIf T = "S" Then
                    T1 = "SKH"
                End If
                For y = 1 To 6: TT = TT & Brr(2, y) & Brr(i, y) & " * ": Next
                Frr(K, 1) = K
                Frr(K, 2) = T1
                Frr(K, 3) = Brr(1, 1) & "--" & Sheets(sht).Name & " 第" & i - 2 & "列" & Chr(10) & Mid(TT, 1, Len(TT) - 3)
                Frr(K, 9) = "=RoundUp((" & (Brr(i, j + 1) & "*" & DSC / 100) & "), -1)"
                Frr(K, 10) = "=sum(i" & K & "*h" & K & ")"
                Frr(K, 11) = Brr(i, j)
                xD.Remove (Brr(i, j))
            End If
        Next
    Next
Next
With Sheets("工作表1")
    With Range(.[a1], .[k1].End(4))
        .Value = ""
        .UnMerge
        .Borders.LineStyle = 0
    End With
    With .[a1].Resize(K, 11)
        .Value = Frr
        .Borders.LineStyle = 1
        For i = 1 To K: .Cells(i, 3).Resize(, 5).Merge: Next
    End With
    .Range("o1:o" & UBound(Arr)).Font.Color = RGB(0, 0, 0)
    For i = 1 To UBound(Arr)
        If xD.Exists(Arr(i, 1) & "") Then .Cells(i, 15).Font.Color = RGB(255, 0, 0)
    Next
End With
Application.ScreenUpdating = True
MsgBox "已完成!  總共：" & Timer - TM & "秒 !"
End Sub