返回列表 上一主題 發帖

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

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
1# 跳轉到 »
發表於 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
複製代碼

TOP

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
2#
發表於 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

TOP

        靜思自在 : 【為善競爭】人生要為善競爭，分秒必爭。
返回列表 上一主題