Board logo

標題: 請高手幫忙囉 [打印本頁]
作者: eric093    時間: 2014-8-11 12:57     標題: 請高手幫忙囉

小弟要計算訂單曾經入款的筆數，
但是公司系統會因為變更付款方式後而產生二個項次，
所以，卡住了，不知道該用什麼方法解決！
請幫忙！
作者: eric093    時間: 2014-8-11 14:35

回復 1# eric093

以附件內容執行後結果應該如下，也就是說，這訂單號碼曾經付款過，入款過，我就要刪除，只留下不曾入款過的

訂單號碼        項次        付款狀況
12345        1        取消
作者: GBKEE    時間: 2014-8-11 15:25

本帖最後由 GBKEE 於 2014-8-12 06:56 編輯

回復 2# eric093
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng As Range, d As Object, i As Variant, A As String
  4.     Set d = CreateObject("scripting.dictionary")
  5.     Set Rng =工作表1.Range("a1").CurrentRegion
  6.     For i = 2 To Rng.Rows.Count
  7.         A = Rng(i, 1) & "-" & Rng(i, 2)
  8.         If d.EXISTS(A) Then   '字典物件的(key值)存在傳回True
  9.             Set d(A) = Union(Rng.Rows(i), d(A))
  10.         Else
  11.             Set d(A) = Rng.Rows(i)
  12.         End If
  13.     Next
  14.     For Each i In d.KEYS
  15.         If d(i).Rows.Count = 1 And InStr(d(i).Cells(3), "取消") = 0 Then
  16.             d(i).Delete xlUp
  17.         ElseIf d(i).Rows.Count > 1 Or d(i).Areas.Count > 1 Then
  18.             d(i).Delete xlUp

  20.         End If
  21.     Next
  22. End Sub
複製代碼
作者: eric093    時間: 2014-8-11 18:32

回復 2# eric093


    感謝大大，不過，這對我來說太難了，我得慢慢研究！
另外，我用我會的方式寫，但有問題，大大可以幫我看一下嗎？

Sub 未入款2()

Application.ScreenUpdating = False
Dim j As Integer
Dim E As Range
Dim xragne, yrange, wrange As Range
Set E = Sheets("未入款").Range("e2")

Application.DisplayAlerts = False


Do While E <> ""
j = 1
     If E.Offset(j) = E Then
     
        
        If E.Offset(, 1) = E.Offset(j, 1) Then
          If E.Offset(, 34) <> E.Offset(j, 34) Then
               If yrange Is Nothing Then Set yrange = E
               If wrange Is Nothing Then Set wrange = E.Offset(1)
              Set yrange = Union(yrange, E)
              Set wrange = Union(wrange, E.Offset(1))
           End If
         
        End If
    Else
     If E(1).Offset(, 34) = "付款確認" Then
       If xragne Is Nothing Then Set xragne = E
              Set xragne = Union(xragne, E)

          End If
    End If
    Set E = E.Offset(1)
    j = j + 1
Loop
If Not xragne Is Nothing Then xragne.EntireRow.Delete
If Not yrange Is Nothing Then yrange.EntireRow.Delete
If Not wrange Is Nothing Then wrange.EntireRow.Delete
End Sub
作者: GBKEE    時間: 2014-8-12 06:46

本帖最後由 GBKEE 於 2014-8-12 06:48 編輯

回復 4# eric093
xlsx 是沒有巨集的Excel檔, xlsm 才可存放程式碼.
  1. Option Explicit
  2. Sub 未入款2()
  3.     Application.ScreenUpdating = False
  4.     Dim j As Integer
  5.     Dim E As Range
  6.     '******宣告變數的型態 ,需依依的指定型態  **********
  7.     Dim xragne As Range, yrange As Range, wrange As Range
  8.     '*******************
  9.     Set E = Sheets("未入款").Range("e2")
  10.     Application.DisplayAlerts = False
  11.     Do While E <> ""                 'orderid 的迴圈
  12.         If E.Offset(, 34) = "付款確認" Then              '付款確認要刪除
  13.             If wrange Is Nothing Then
  14.                 Set wrange = E
  15.             Else
  16.                 Set wrange = Union(wrange, E)
  17.             End If
  18.         End If
  19.         j = 1
  20.         Do While E.Offset(j) <> ""                     '每一個orderid往下的迴圈
  21.             If E.Offset(j) = E Then                     ' 相同的 orderid
  22.                 If E.Offset(, 1) = E.Offset(j, 1) Then  ' 相同的 itemid 要刪除
  23.                     If wrange Is Nothing Then
  24.                         Set wrange = Union(E, E.Offset(j))
  25.                     Else
  26.                         Set wrange = Union(wrange, E, E.Offset(j))
  27.                     End If
  28.                 End If
  29.             End If
  30.             j = j + 1
  31.         Loop
  32.         Set E = E.Offset(1)
  33.     Loop
  34.     If Not wrange Is Nothing Then wrange.EntireRow.Delete
  35. End Sub
複製代碼
作者: eric093    時間: 2014-8-12 11:53

回復 5# GBKEE


    謝謝版大，我來看一下我寫哪出錯了
作者: eric093    時間: 2014-8-13 22:38

回復 3# GBKEE

版主：問題是解決了，但我找了一些關於字典物件的資料，我有點搞不太懂，可以幫我開示嗎
            幫我解惑下面這段嗎
    Option Explicit
Sub Ex()
    Dim Rng As Range, d As Object, i As Variant, A As String
    Set d = CreateObject("scripting.dictionary")
    Set Rng =工作表1.Range("a1").CurrentRegion
    For i = 2 To Rng.Rows.Count
        A = Rng(i, 1) & "-" & Rng(i, 2)
        If d.EXISTS(A) Then   '字典物件的(key值)存在傳回True
            Set d(A) = Union(Rng.Rows(i), d(A)) ==========？？
        Else
            Set d(A) = Rng.Rows(i)   ==========？？

        End If
    Next
    For Each i In d.KEYS  ==========？？

        If d(i).Rows.Count = 1 And InStr(d(i).Cells(3), "取消") = 0 Then
            d(i).Delete xlUp
        ElseIf d(i).Rows.Count > 1 Or d(i).Areas.Count > 1 Then
            d(i).Delete xlUp

        End If
    Next
End Sub
作者: GBKEE    時間: 2014-8-14 06:11

回復 7# eric093
  1. Dictionary 物件
  2. 可以是任何型式的資料的項目被儲存在陣列中。每個項目都與一個唯一的關鍵字相關。該關鍵字用來取出單個項目，通常是整數或字串，可以是除陣列外的任何型態。
複製代碼
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng As Range, d As Object, i As Variant, A As String
  4.     Set d = CreateObject("scripting.dictionary")
  5.     Set Rng = 工作表1.Range("a1").CurrentRegion
  6.     For i = 2 To Rng.Rows.Count
  7.         A = Rng(i, 1) & "-" & Rng(i, 2)
  8.         If d.EXISTS(A) Then   '字典物件的(key值)存在傳回True
  9.             Set d(A) = Union(Rng.Rows(i), d(A)) ' ==========？？
  10.         Else
  11.             Set d(A) = Rng.Rows(i)   '==========？？
  12.         End If
  13.         MsgBox d(A).Address
  14.     Next
  15.     For Each i In d.KEYS  '==========？？
  16.         MsgBox i
  17.         If d(i).Rows.Count = 1 And InStr(d(i).Cells(3), "取消") = 0 Then
  18.             d(i).Delete xlUp
  19.         ElseIf d(i).Rows.Count > 1 Or d(i).Areas.Count > 1 Then
  20.             d(i).Delete xlUp
  21.         End If
  22.     Next
  23. End Sub
複製代碼
作者: Andy2483    時間: 2023-4-19 16:30

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

執行前:
[attach]36190[/attach]

執行結果:
[attach]36191[/attach]


Option Explicit
Sub TEST()
Dim Brr, Y, R&, i&, j&, TT, T1$, T2$, T3$, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([C2], Cells(Rows.Count, "A").End(3)): Brr = xR
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): T2 = Brr(i, 2): T3 = Brr(i, 3): TT = T1 & "|" & T2
   If Y(TT) <> "成功" Then Y(TT) = T3: Y(TT & "|r") = i
Next
For Each TT In Y.keys
   If TT Like "*|r" Or Y(TT) = "成功" Then GoTo i00
   R = R + 1: For j = 1 To 3: Brr(R, j) = Brr(Y(TT & "|r"), j): Next
i00: Next
If R = 0 Then GoTo i01
xR.Offset(1, 0).ClearContents: xR.Resize(R, 3) = Brr
i01: Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub



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