返回列表 上一主題 發帖

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

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

請教各位:

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

館別廠商自動選擇.zip (46.11 KB)

回復 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
複製代碼
學海無涯_不恥下問

TOP

感謝版主大力協助,但可能是我沒說清楚,
擷取.PNG
2019-1-16 15:58

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


我原本希望是能依 館別及廠商的分頁工作表上
擷取.PNG
2019-1-16 16:12

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

TOP

回復 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
複製代碼

TOP

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

TOP

回復 4# Kubi


請問Kudi大大:

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

館別廠商自動選擇.zip (53.83 KB)

TOP

本帖最後由 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

TOP

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

TOP

謝謝論壇(5001),謝謝各位前輩
後學藉此帖練習陣列,學習方案如下,請各位前輩指教
結果表清除舊資料:
20240112_1.jpg
2024-1-12 11:06


資料表:
20240112_2.jpg
2024-1-12 11:06


執行結果:
20240112_3.jpg
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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

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

TOP

        靜思自在 : 對父母要知恩,感恩、報恩。
返回列表 上一主題