[發問] 如何輸入兩個資料自總表中篩出資料，輸入在另一分頁

tsuan

請教各位：

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

Hsieh

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

感謝版主大力協助，但可能是我沒說清楚，

下載 (22.96 KB)

2019-1-16 15:58

我需要的是抓A欄位的館別及L欄位的廠商交集的資料，產生如下表的資料


我原本希望是能依 館別及廠商的分頁工作表上

下載 (19.37 KB)

2019-1-16 16:12

想在C1 及 E1 輸入篩選條件後，抓取資料後產生資料於該頁面，但如版主直接生成新的工作表實際上更符合我的需要。
還請版主再協助，不勝感激。

Kubi

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

感謝 Kubi
正是如我所需要的，非常感激

tsuan

回復 4# Kubi


請問Kudi大大:

我在總表資料上方插入一列，即出現陣列索引書線錯誤訊息，懇請您再指導一下，謝謝。

Kubi

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

感謝 Kubi
已經可以正式使用了，非常感謝

Andy2483

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

下載 (54.83 KB)

2024-1-12 11:06

資料表:

下載 (299.42 KB)

2024-1-12 11:06

執行結果:

下載 (142.3 KB)

2024-1-12 11:07

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

回復 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) 是什麼意思呢? 是怎樣用法呢? 我在網上找過,但都還是一頭霧水,所以想請學兄指教,謝謝