Board logo

標題: [發問] 如何輸入兩個資料自總表中篩出資料，輸入在另一分頁 [打印本頁]
作者: tsuan    時間: 2019-1-15 14:28     標題: 如何輸入兩個資料自總表中篩出資料，輸入在另一分頁

請教各位：

我想將附件中的總表資料頁中，依照館別及廠商別抓出資料另存入館別及廠商分頁中，因資料內容欄位會隨每次筆數不同，所以不會是固定筆數，
程度太差期待高人指點。
作者: Hsieh    時間: 2019-1-15 16:05

回復 1# tsuan
  1. Sub 分類()
  2. Dim A As Range, Ay()
  3. Set Sht = CreateObject("Scripting.Dictionary")
  4. Set dic = CreateObject("Scripting.Dictionary")
  5. With Sheets("總表")
  6. For Each A In .Range(.[A2], .[A2].End(xlDown))
  7. For i = 5 To 9
  8.    ar = Array(A.Offset(, 1), A.Offset(, 2), A.Offset(, 3), .Cells(A.Row, i).Value)
  9.    If IsEmpty(dic(A & " " & .Cells(1, i))) Then
  10.    ReDim Preserve Ay(1)
  11.    Ay(0) = Array("貨號", "貨品描述", "單位", "價格") '標題列
  12.    Ay(1) = ar '資料列
  13.       dic(A & " " & .Cells(1, i)) = Ay '暫存於字典物件中
  14.       Else
  15.       Ay = dic(A & " " & .Cells(1, i)) '讀出字典內容
  16.       s = UBound(Ay)
  17.       ReDim Preserve Ay(s + 1)
  18.       Ay(s + 1) = ar '加入資料列
  19.       dic(A & " " & .Cells(1, i)) = Ay '暫存於字典物件中
  20.     End If
  21. Next
  22. Next
  23. End With
  24. For Each sh In Sheets '讀取所有工作表名稱
  25.    Sht(sh.Name) = sh.Name
  26. Next
  27. For Each ky In dic.keys
  28. If Not Sht.exists(ky) Then '若工作表不存在
  29. With Worksheets.Add(after:=Sheets(Sheets.Count)) '新增工作表
  30.    .Name = ky
  31. End With
  32. End If
  33. With Sheets(ky) '寫入工作表資料
  34.    .[B1] = "館別:"
  35.    .[D1] = "廠商:"
  36.    .[C1] = Split(ky, " ")(0)
  37.    .[E1] = Split(ky, " ")(1)
  38.    .[A3].Resize(UBound(dic(ky)) + 1, 4) = Application.Transpose(Application.Transpose(dic(ky)))
  39. End With
  40. Next
  41. End Sub
複製代碼
作者: tsuan    時間: 2019-1-16 16:19

感謝版主大力協助，但可能是我沒說清楚，
[attach]29964[/attach]
我需要的是抓A欄位的館別及L欄位的廠商交集的資料，產生如下表的資料
[attach]29964[/attach]

我原本希望是能依 館別及廠商的分頁工作表上
[attach]29967[/attach]
想在C1 及 E1 輸入篩選條件後，抓取資料後產生資料於該頁面，但如版主直接生成新的工作表實際上更符合我的需要。
還請版主再協助，不勝感激。
作者: Kubi    時間: 2019-1-19 10:03

回復 1# tsuan
請參考
  1. Sub test()
  2.     Dim d As Object
  3.     Dim arr
  4.     Dim brr()
  5.     Set d = CreateObject("Scripting.Dictionary")
  6.     With Sheets("總表")
  7.         er = .[A65536].End(3).Row
  8.         arr = .Range("A2:L" & er)
  9.         For c = 5 To 9
  10.             d(.Cells(1, c).Value) = c
  11.         Next c
  12.     End With
  13.     room = Sheets("館別及廠商").[C1].Value
  14.     store = Sheets("館別及廠商").[E1].Value
  15.     n = 0
  16.     For i = 1 To UBound(arr)
  17.         If arr(i, 1) = room And arr(i, 12) = store Then
  18.             n = n + 1
  19.             ReDim Preserve brr(1 To 4, 1 To n)
  20.             For j = 1 To 3
  21.                 brr(j, n) = arr(i, j + 1)
  22.             Next j
  23.             brr(4, n) = arr(i, d(store))
  24.         End If
  25.     Next i
  26.     If n <> 0 Then
  27.         Sheets("館別及廠商").Rows("4:65536").Delete
  28.         Sheets("館別及廠商").[A4].Resize(n, 4) = Application.Transpose(brr)
  29.     Else
  30.         MsgBox "找不到"
  31.     End If
  32.     Set d = Nothing
  33.     Erase brr
  34.     arr = ""
  35. End Sub
複製代碼
作者: tsuan    時間: 2019-1-19 17:27

感謝 Kubi
正是如我所需要的，非常感激
作者: tsuan    時間: 2019-3-22 16:09

回復 4# Kubi


請問Kudi大大:

我在總表資料上方插入一列，即出現陣列索引書線錯誤訊息，懇請您再指導一下，謝謝。
作者: Kubi    時間: 2019-3-25 20:33

本帖最後由 Kubi 於 2019-3-25 20:34 編輯
  1. Sub test()
  2.     Dim d As Object
  3.     Dim arr
  4.     Dim brr()
  5.     Set d = CreateObject("Scripting.Dictionary")
  6.     With Sheets("總表")
  7.         er = .[A65536].End(3).Row
  8.         arr = .Range("A3:L" & er)
  9.         For c = 5 To 9
  10.            d(.Cells(2, c).Value) = c
  11.         Next c
  12.     End With
  13.     room = Sheets("館別及廠商").[C1].Value
  14.     store = Sheets("館別及廠商").[E1].Value
  15.     n = 0
  16.     For i = 1 To UBound(arr)
  17.         If arr(i, 1) = room And arr(i, 12) = store Then
  18.             n = n + 1
  19.             ReDim Preserve brr(1 To 4, 1 To n)
  20.             For j = 1 To 3
  21.                 brr(j, n) = arr(i, j + 1)
  22.             Next j
  23.             brr(4, n) = arr(i, d(store))
  24.         End If
  25.     Next i
  26.     If n <> 0 Then
  27.         Sheets("館別及廠商").Rows("4:65536").Delete
  28.         Sheets("館別及廠商").[A4].Resize(n, 4) = Application.Transpose(brr)
  29.     Else
  30.         MsgBox "找不到"
  31.     End If
  32.     Set d = Nothing
  33.     Erase brr
  34.     arr = ""
  35. End Sub
複製代碼
回復 6# tsuan
作者: tsuan    時間: 2019-5-4 08:29

感謝 Kubi
已經可以正式使用了，非常感謝
作者: Andy2483    時間: 2024-1-12 11:07

謝謝論壇(5001),謝謝各位前輩
後學藉此帖練習陣列,學習方案如下,請各位前輩指教
結果表清除舊資料:
[attach]37280[/attach]

資料表:
[attach]37281[/attach]

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

Option Explicit
Sub TEST()
Dim Brr, V, Z, i&, R&, 館$, 廠$
Sheets("館別及廠商").UsedRange.Offset(3).EntireRow.Delete
館 = [館別及廠商!C1]: 廠 = [館別及廠商!E1]: If 館 = "" Or 廠 = "" Then Exit Sub
Brr = Range([總表!L1], [總表!A65536].End(xlUp))
For i = 3 To UBound(Brr)
   If Brr(i, 1) <> 館 Or Brr(i, 12) <> 廠 Then GoTo i01 Else R = R + 1
   Brr(R, 1) = Brr(i, 2): Brr(R, 2) = Brr(i, 3): Brr(R, 3) = Brr(i, 4)
   Brr(R, 4) = Val(Brr(i, 11)): Brr(R, 5) = Val(Brr(i, 10))
   V = V + Brr(R, 4) * Brr(R, 5)
i01: Next
If R = 0 Then Exit Sub
With [館別及廠商!A4].Resize(R, 5)
   .Value = Brr: .Item(0, 5) = "=總表!J2"
   For i = 7 To 10: .Borders(i).Weight = 4: Next
   .Item(.Count + 4) = "合計": .Item(.Count + 5) = V
   .Item(.Count + 5).NumberFormatLocal = "G/通用格式""元"""
End With
End Sub
作者: mdr0465    時間: 2024-3-4 22:23

回復 9# Andy2483

Andy 學兄, 後輩有一些編碼上的疑問想向你請教

Sub TEST()
Dim Brr, V, Z, i&, R&, 館$, 廠$
Sheets("館別及廠商").UsedRange.Offset(3).EntireRow.Delete
館 = [館別及廠商!C1]: 廠 = [館別及廠商!E1]: If 館 = "" Or 廠 = "" Then Exit Sub
Brr = Range([總表!L1], [總表!A65536].End(xlUp))
For i = 3 To UBound(Brr)
   If Brr(i, 1) <> 館 Or Brr(i, 12) <> 廠 Then GoTo i01 Else R = R + 1
   Brr(R, 1) = Brr(i, 2): Brr(R, 2) = Brr(i, 3): Brr(R, 3) = Brr(i, 4)
   Brr(R, 4) = Val(Brr(i, 11)): Brr(R, 5) = Val(Brr(i, 10))
   V = V + Brr(R, 4) * Brr(R, 5)
i01: Next
If R = 0 Then Exit Sub
With [館別及廠商!A4].Resize(R, 5)
   .Value = Brr: .Item(0, 5) = "=總表!J2"
   For i = 7 To 10: .Borders(i).Weight = 4: Next
  .Item(.Count + 4) = "合計": .Item(.Count + 5) = V
  .Item(.Count + 5).NumberFormatLocal = "G/通用格式""元"""
End With
End Sub

請問以上紅色的標記 ".item(xxxxx) 是什麼意思呢? 是怎樣用法呢? 我在網上找過,但都還是一頭霧水,所以想請學兄指教,謝謝
作者: Andy2483    時間: 2024-3-5 07:43

回復 10# mdr0465


    謝謝前輩一起學習
請試執行以下代碼:
[attach]37548[/attach]

Option Explicit
Sub Item_test()
Dim xA As Range, N&
With [A2:E4]
   N = .Count: .Select
   MsgBox "此區域儲存格的數量有: " & N & " 個"
   MsgBox "此區域儲存格裡的第1欄第1列儲存格位址是 " & .Item(1, 1).Address(0, 0)
   MsgBox "此區域儲存格裡的第5欄第3列儲存格位址是 " & .Item(3, 5).Address(1, 0)
   MsgBox "此區域儲存格裡的第6欄第3列儲存格位址是 " & .Item(3, 6).Address(0, 1)
   MsgBox "此區域儲存格裡的第1個儲存格位址是 " & .Item(1).Address(1, 1)
   MsgBox "此區域儲存格裡的第5個儲存格位址是 " & .Item(5).Address
   MsgBox "此區域儲存格裡的第6個儲存格位址是 " & .Item(6).Address
   MsgBox "此區域儲存格裡的最後一個儲存格位址是 " & .Item(N).Address
   MsgBox "此區域儲存格上一列第5欄儲存格位址是 " & .Item(0, 5).Address
End With
End Sub
作者: mdr0465    時間: 2024-3-5 12:37

回復 11# Andy2483
Andy 學兄
晚輩十分感謝你耐心的教導,現在明白了當中的運用和技巧,
謝謝你



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