返回列表 上一主題 發帖

[發問] 將多筆同單號的資料放入一個儲存格內,資料不重複及多條件加總

回復 1# yliu
試試看
  1. Option Explicit
  2. Sub EX_1()   '表1的程式
  3.     Dim 訂單號碼 As String, 請購單號 As String, 請購廠商 As String
  4.     Dim AR(1 To 6), i As Integer
  5.     With Sheets("report")
  6.         訂單號碼 = .[B5]
  7.         請購單號 = .[D5]
  8.         請購廠商 = .[B6]
  9.         With Sheets("final")
  10.             i = 2
  11.             Do While .Cells(i, "A") <> ""
  12.                 If .Cells(i, "v").Value = 訂單號碼 And .Cells(i, "F") = 請購單號 And .Cells(i, "L") = 請購廠商 Then
  13.                     AR(1) = .Cells(i, "j")                      '品名
  14.                     AR(2) = AR(2) & IIf(AR(2) = "", "", ",") & .Cells(i, "k") '規格
  15.                     AR(3) = .Cells(i, "i")                      '會計科目
  16.                     AR(4) = .Cells(i, "b")                      '採購性質
  17.                     AR(5) = AR(5) + .Cells(i, "m")                    'User請購價
  18.                     AR(6) = .Cells(i, "c")                  '採購類別
  19.                 End If
  20.                 i = i + 1
  21.             Loop
  22.         End With
  23.         .[B7] = AR(1)
  24.         .[B8] = AR(2)
  25.         .[B9] = AR(3)
  26.         .[D9] = AR(4)
  27.         .[B10] = AR(5)
  28.         .[D10] = AR(6)
  29.      End With
  30. End Sub
  31. Sub EX_2()  '表1的程式
  32.     Dim d As Object, KEY, i As Integer, AR(), A(1 To 4), 訂單號碼 As String
  33.     Set d = CreateObject("SCRIPTING.DICTIONARY")                   '字典物件 Scripting.Dictionary
  34.     訂單號碼 = Sheets("report").[B5]
  35.     With Sheets("record")
  36.         .AutoFilterMode = False                                     '取消 工作表的自動篩選
  37.             i = 2
  38.             Do While .Cells(i, "A") <> ""
  39.                 If .Cells(i, "P").Value = 訂單號碼 Then             '比對 訂單號碼
  40.                     If d.exists(.Cells(i, "C").Value) = False Then d(.Cells(i, "C").Value) = .Cells(i, "C")
  41.                 End If
  42.                 i = i + 1
  43.             Loop
  44.             ReDim AR(1 To d.Count)                                  '重置陣列的元素上限=字典物件的計數(Count)
  45.            .Range("A1").AutoFilter 16, 訂單號碼                     'AutoFilter 自動篩選 第16欄 指定條件值=訂單號碼
  46.            i = 1
  47.            For Each KEY In d.KEYS
  48.             .Range("A1").AutoFilter 3, KEY                          'AutoFilter 自動篩選 第3欄 指定條件值=字典物件的KEY
  49.             A(1) = KEY                                                             '採購廠商
  50.             A(2) = Application.Sum(.Range("M:M").SpecialCells(xlCellTypeVisible))  '第1次議價
  51.             A(3) = Application.Sum(.Range("N:N").SpecialCells(xlCellTypeVisible))  '第2次議價
  52.             A(4) = Application.Sum(.Range("O:O").SpecialCells(xlCellTypeVisible))  '第3次議價
  53.             AR(i) = A
  54.             i = i + 1
  55.         Next
  56.     End With
  57.     Sheets("report").[B13].Resize(4, 3) = Application.WorksheetFunction.Transpose(AR) '導入
  58. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 3# yliu
  1. Do While .Cells(i, "A") <> ""
  2.                 If .Cells(i, "v").Value = 訂單號碼 And .Cells(i, "F") = 請購單號 And .Cells(i, "L") = 請購廠商 Then
  3.                       '**********************************************************
  4.                     If AR(1) = "" Then
  5.                         AR(1) = .Cells(i, "J")                                                     '品名
  6.                     Else
  7.                         M = Application.Match(.Cells(i, "J"), Split(AR(1), ","), 0)                 '尋找相同的品名
  8.                         If IsError(M) Then AR(1) = AR(1) & "," & .Cells(i, "J")                     '尋找不到時 Match傳回 錯誤值
  9.                     End If
  10.                  '*********************************************************   
  11.                     AR(2) = AR(2) & IIf(AR(2) = "", "", ",") & .Cells(i, "k") '規格
  12.                     AR(3) = .Cells(i, "i")                      '會計科目
  13.                     AR(4) = .Cells(i, "b")                      '採購性質
  14.                     AR(5) = AR(5) + .Cells(i, "m")                    'User請購價
  15.                     AR(6) = .Cells(i, "c")                  '採購類別
  16.                 End If
  17.                 i = i + 1
  18.             Loop
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 6# yliu
上傳檔案看看
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 8# yliu
檢查一下:dic的個數,如為0時要有if 的判斷式.
  1. MsgBox dic.Count            
  2.             ReDim AR2(1 To dic.Count)                                  '重置陣列的元素上限=字典物件的計數(Count)
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 13# yliu
  1.   ReDim AR2(1 To dic.Count)
  2.             '重置陣列的元素上限=字典物件的計數(Count)
  3.            .Range("A1").AutoFilter 16, 訂單號碼2                     'AutoFilter 自動篩選 第16欄 指定條件值=訂單號碼
  4.            i2 = 1
  5.            For Each KEY In dic.Keys
  6.                 .Range("A1").AutoFilter 3, KEY                          'AutoFilter 自動篩選 第3欄 指定條件值=字典物件的KEY
  7.                 A(1) = KEY                                                             '採購廠商
  8.                 A(2) = Application.Sum(.Range("M:M").SpecialCells(xlCellTypeVisible))  '第1次議價 '已用範圍的最後一個儲存格
  9.                 A(3) = Application.Sum(.Range("N:N").SpecialCells(xlCellTypeVisible))  '第2次議價 '已用範圍的最後一個儲存格
  10.                 A(4) = Application.Sum(.Range("O:O").SpecialCells(xlCellTypeVisible))  '第3次議價 '已用範圍的最後一個儲存格
  11.                 AR2(i2) = A
  12.                 i2 = i2 + 1
  13.             Next
  14.     End With
  15.     Sheets("report").[B13].Resize(4, dic.Count) = Application.WorksheetFunction.Transpose(AR2)  '導入
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 信心、毅力、勇氣三者具備,則天下沒有做不成的事。
返回列表 上一主題