返回列表 上一主題 發帖

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

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

請教各位:

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

館別廠商自動選擇.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

        靜思自在 : 真正的愛心,是照顧好自己的這顆心。
返回列表 上一主題