Board logo

標題: [發問] 將多筆同單號的資料放入一個儲存格內,資料不重複及多條件加總 [打印本頁]
作者: yliu    時間: 2013-7-26 22:19     標題: 將多筆同單號的資料放入一個儲存格內,資料不重複及多條件加總

請問版上高手,
1.請問有可能做到將多筆同單號的資料放入一個儲存格內,然後資料不重複(如圖一)
[attach]15591[/attach]

2.圖二 的表如何寫加總VBA?
[attach]15593[/attach][attach]15594[/attach]
作者: GBKEE    時間: 2013-7-27 12:35

回復 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
複製代碼
作者: yliu    時間: 2013-7-29 23:30

回復 2# GBKEE

感謝GBKEE的解答.程式碼可以使用,
只是想再問一下, 有沒有可能可以做到讀取第1筆序號的品名時,就放入"report" 儲存格[B7]，讀取第2筆序號的品名時,如果品名與第1筆序號的品名不一樣時也放入"report" 儲存格[B7]，讀取第3筆序號的品名時如果品名與第1筆序號或第2筆序號品名相同時,就不放入"report" 儲存格[B7].
還是說, 只能做到就只能夠取最後一筆資料放入"report" 儲存格[B7]，要不然就是3筆序號的資料皆放入儲存格(如規格的欄位,儲存格[B8]那樣).
麻煩你了,謝謝!
作者: GBKEE    時間: 2013-7-30 06:43

回復 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
複製代碼
作者: yliu    時間: 2013-7-31 00:11

回復 4# GBKEE

感謝GBKEE版大,
你實在太厲害了, 這程式碼完全符合我想要的東西,萬分感謝~
作者: yliu    時間: 2013-8-1 13:41

回復 4# GBKEE

GBKEE版大,
“final”工作表資料只有1筆訂單號碼時,可以執行
後來,我加了第2筆訂單號碼資料後,執行卻出現:
執行階段錯誤9
陣列索引超出範圍
偵錯在:
ReDim AR2(1 To d.Count)       '重置陣列的元素上限=字典物件的計數(Count)

請問是什麼原因?
作者: GBKEE    時間: 2013-8-1 14:57

回復 6# yliu
上傳檔案看看
作者: yliu    時間: 2013-8-1 23:38

回復 7# GBKEE

GBKEE版大,
麻煩請你幫我看一下檔案,問題出在哪裡. 謝謝!

[attach]15669[/attach]
作者: GBKEE    時間: 2013-8-8 16:04

回復 8# yliu
檢查一下:dic的個數,如為0時要有if 的判斷式.
  1. MsgBox dic.Count            
  2.             ReDim AR2(1 To dic.Count)                                  '重置陣列的元素上限=字典物件的計數(Count)
複製代碼
作者: yliu    時間: 2013-8-11 15:01

回復 9# GBKEE

謝謝GBKEE的指導,
加了 If dic.count=0 的判斷式,已經ok了,謝謝.
作者: 97forum    時間: 2013-8-12 10:29

回復  GBKEE

謝謝GBKEE的指導,
加了 If dic.count=0 的判斷式,已經ok了,謝謝.
yliu 發表於 2013-8-11 15:01


不好意思由於我是新手，不知 YLiu是否可將您程式碼提供下載供參考！
作者: yliu    時間: 2013-8-14 23:34

回復 11# 97forum

[attach]15777[/attach]檔案附上, 我也是新手, 所以沒有修改的很好, 但至少可以Run.
作者: yliu    時間: 2013-8-14 23:48

回復 9# GBKEE
    GBKEE版大,
不好意思, 又出現另一個問題, 若是詢價廠商只有2家時, 無第3家廠商, 會出現#NA符號(如圖), 請問如何讓它是空白的?
[attach]15778[/attach]
[attach]15779[/attach]
作者: GBKEE    時間: 2013-8-15 16:01

回復 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)  '導入
複製代碼
作者: yliu    時間: 2013-8-17 23:47

回復 14# GBKEE

謝謝GBKEE版大,已經解決了.
作者: c_c_lai    時間: 2013-8-18 09:21

本帖最後由 c_c_lai 於 2013-8-18 09:22 編輯

回復 15# yliu
將你目前的 Report 予以稍稍整理一下，方便閱讀及縮小(精簡)程式碼。
供你參考與應用：
  1. Private Sub ComboBox1_Change()
  2.     Dim d As Object, j As Integer
  3.    
  4.     Sheets("report").Unprotect ("789456123")
  5.    ClearFlds
複製代碼
  1.         If dic.Count = 0 Then
  2.             MsgBox "沒有議價資料"
  3.             ClearFlds
  4.            Exit Sub
  5.         End If
複製代碼
  1. Sub ClearFlds()
  2.     With Sheets("report")
  3.         ' .Cells(5, 2) = ""
  4.         ' .Cells(6, 2) = ""
  5.         ' .Cells(7, 2) = ""
  6.         ' .Cells(8, 2) = ""
  7.         ' .Cells(9, 2) = ""
  8.         ' .Cells(10, 2) = ""
  9.         ' .Cells(13, 2) = ""
  10.         ' .Cells(14, 2) = ""
  11.         ' .Cells(15, 2) = ""
  12.         ' .Cells(16, 2) = ""
  13.         ' .Cells(18, 2) = ""
  14.         ' .Cells(19, 2) = ""
  15.         ' .Cells(20, 2) = ""
  16.         ' .Cells(21, 2) = ""
  17.         .Range("B5:B10") = ""
  18.         .Range("B13:B21") = ""
  19.    
  20.         ' .Cells(13, 3) = ""
  21.         ' .Cells(14, 3) = ""
  22.         ' .Cells(15, 3) = ""
  23.         ' .Cells(16, 3) = ""
  24.         .Range("C13:C16") = ""
  25.    
  26.         .Cells(5, 4) = ""
  27.         ' .Cells(9, 4) = ""
  28.         ' .Cells(10, 4) = ""
  29.         .Range("D9:D10") = ""
  30.    
  31.         ' .Cells(13, 4) = ""
  32.         ' .Cells(14, 4) = ""
  33.         ' .Cells(15, 4) = ""
  34.         ' .Cells(16, 4) = ""
  35.         ' .Cells(20, 4) = ""
  36.         ' .Cells(21, 4) = ""
  37.         .Range("D13:D21") = ""
  38.     End With
  39. End Sub
複製代碼
[attach]15799[/attach]
作者: yliu    時間: 2013-8-18 20:28

回復 16# c_c_lai
謝謝c c lai的指導



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