返回列表 上一主題 發帖

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

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

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

%%2020.rar (414.43 KB)

本帖最後由 軒云熊 於 2021-4-4 22:10 編輯

回復 1# agietron

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

TOP

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

TOP

回復 1# agietron


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

TOP

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

比對後:

比對後

比對後.JPG
6 天前 13:49

TOP

本帖最後由 軒云熊 於 2021-4-5 23:09 編輯

回復 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)

TOP

回復 6# 軒云熊


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

TOP

回復 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

TOP

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

TOP

回復 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

TOP

        靜思自在 : 小事不做、大事難成。
返回列表 上一主題