請教以字典抓取符合條件資料後輸出 - Excel程式區

帖子: 2798
主題: 10
精華: 0
積分: 2854
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-4-20

1^# 跳轉到 »

發表於 2021-11-24 11:29 | 顯示全部帖子

1.當DATA所在地=盤點表B2時。
__B2底下還有其它"所在地", 怎解??

2.若遇到財產編號相同者，只列出頭一筆。
__只列一筆, 要不要累計?

3.將各所在地之資料分別輸出，以分頁區分。
__若同一所在地, 資料行數太多, 列印超過一頁, 怎解??

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2798
主題: 10
精華: 0
積分: 2854
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-4-20

2^#

發表於 2021-11-25 21:58 | 顯示全部帖子

若資料多, 且每所在地的項目不超過999種, 可參考此方法:
放在同一頁, 每所在地底下加"分頁線", 使用預覽即可明白:

Xl0000031-1.rar (50.32 KB)

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2798
主題: 10
精華: 0
積分: 2854
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-4-20

3^#

發表於 2021-11-28 11:17 | 顯示全部帖子

再發一版--純篩選複製至各分表:

Xl0000031-2.rar (55.71 KB)

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2798
主題: 10
精華: 0
積分: 2854
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-4-20

4^#

發表於 2021-11-28 18:12 | 顯示全部帖子

少算一行:
.Rows(1).Resize(.Rows.Count ).Copy xS.[a4]
改成
.Rows(2).Resize(.Rows.Count - 1).Copy xS.[a4]

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2798
主題: 10
精華: 0
積分: 2854
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-4-20

5^#

發表於 2021-12-4 13:26 | 顯示全部帖子

回復 18# shuo1125

Sub TEST_A4()
Dim Arr, Brr, Cr, xD, vD, i&, j%, R&, K, T1$, T2$, TT$, N&, V%, xA As Range
tm = Timer
Call 清除
Set xD = CreateObject("Scripting.Dictionary")
Set vD = CreateObject("Scripting.Dictionary")
Arr = Range([DATA!at1], [DATA!a65536].End(xlUp))
For i = 2 To UBound(Arr)
If Arr(i, 46) <> "" Then GoTo i01
T1 = Arr(i, 11): T2 = Arr(i, 6): TT = T1 & T2
If T1 = "" Or T2 = "" Or xD(TT) > 0 Then GoTo i01
If xD(T1) = 0 Then Set vD(T1) = CreateObject("Scripting.Dictionary")
xD(T1) = 1: xD(TT) = 1: vD(T1)(i) = ""
i01: Next i
'--------------------------------
Application.ScreenUpdating = False
Set xA = [盤點表!A1]: Cr = Array(1, 3, 6, 8, 10, 14, 13, 12)
For Each K In vD.keys
R = vD(K).Count: N = N + 1
ReDim Brr(1 To R + 1, 1 To 10)
For i = 1 To R
      V = vD(K).keys()(i - 1)
      Brr(i + 1, 5) = "小計：": Brr(i + 1, 8) = Brr(i, 8) + Arr(V, 12)
      For j = 1 To 8:  Brr(i, j) = Arr(V, Cr(j - 1)): Next
Next i
[盤點表!A1:j3].Copy xA
xA(2, 2) = K: xA(2, 10) = "頁次：" & N & "/" & vD.Count
[盤點表!a4:j4].Copy xA(4).Resize(R, 10)
xA(4).Resize(R + 1, 10).Value = Brr
Set xA = xA(R + 5): xA.PageBreak = xlPageBreakManual '設定分頁線
Next
MsgBox Timer - tm
End Sub

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2798
主題: 10
精華: 0
積分: 2854
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-4-20

6^#

發表於 2021-12-10 20:26 | 顯示全部帖子

回復 21# shuo1125

For i = 1 To R
      V = vD(K).keys()(i - 1)
      Brr(i + 1, 5) = "小計：": Brr(i + 1, 8) = Brr(i, 8) + Arr(V, 12)
      For j = 1 To 8:  Brr(i, j) = Arr(V, Cr(j - 1)): Next
      Brr(i, 10) = "口人員口地點口功能"
Next i

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2798
主題: 10
精華: 0
積分: 2854
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-4-20

7^#

發表於 2021-12-10 21:10 | 顯示全部帖子

回復 23# shuo1125

Sub TEST_A4()
Dim Arr, Brr, Cr, xD, vD, i&, j%, R&, K, T1$, T2$, TT$, N&, V%, xA As Range
tm = Timer
Call 清除
Set xD = CreateObject("Scripting.Dictionary")
Set vD = CreateObject("Scripting.Dictionary")
Arr = Range([DATA!at1], [DATA!a65536].End(xlUp))
For i = 2 To UBound(Arr)
If Arr(i, 46) <> "" Then GoTo i01
T1 = Arr(i, 11): T2 = Arr(i, 6): TT = T1 & T2
If T1 = "" Or T2 = "" Or xD(TT) > 0 Then GoTo i01
If xD(T1) = 0 Then Set vD(T1) = CreateObject("Scripting.Dictionary")
xD(T1) = 1: xD(TT) = 1: vD(T1)(i) = ""
i01: Next i
'--------------------------------
Application.ScreenUpdating = False
Set xA = [盤點表!A1]: Cr = Array(1, 3, 6, 8, 10, 14, 13, 12)
For Each K In vD.keys
R = vD(K).Count: N = N + 1
ReDim Brr(1 To R + 1, 1 To 10)
For i = 1 To R
      V = vD(K).keys()(i - 1)
      Brr(i + 1, 5) = "小計：": Brr(i + 1, 8) = Brr(i, 8) + Arr(V, 12)
      For j = 1 To 8:  Brr(i, j) = Arr(V, Cr(j - 1)): Next
      Brr(i, 10) = "口人員口地點口功能"
Next i
[盤點表!A1:j3].Copy xA
xA(2, 2) = K: xA(2, 10) = "頁次：" & N & "/" & vD.Count
[盤點表!a4:j4].Copy xA(4).Resize(R, 10)
xA(4).Resize(R + 1, 10).Value = Brr
Set xA = xA(R + 5): xA.PageBreak = xlPageBreakManual '設定分頁線
Next
MsgBox Timer - tm
End Sub

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2798
主題: 10
精華: 0
積分: 2854
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-4-20

8^#

發表於 2021-12-10 21:13 | 顯示全部帖子

回復 23# shuo1125

Sub TEST_A1()
Dim Arr, Brr(1 To 999, 1 To 10), Crr, xD, i&, j%, T1$, T2$, TT$, R&, N&, xA As Range
tm = Timer
Call 清除
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([DATA!at1], [DATA!a65536].End(xlUp))
For i = 2 To UBound(Arr)
If Arr(i, 46) <> "" Then GoTo i01
T1 = Arr(i, 11): T2 = Arr(i, 6): TT = T1 & "|" & T2
If T1 = "" Or T2 = "" Or xD(TT) > 0 Then GoTo i01
Crr = xD(T1 & "/c"): xD(TT) = 1: xD(T1) = xD(T1) + 1
If Not IsArray(Crr) Then Crr = Brr: N = N + 1: xD(N) = T1
For j = 1 To 8
      Crr(xD(T1), j) = Arr(i, Array(1, 3, 6, 8, 10, 14, 13, 12)(j - 1))
Next j
Crr(xD(T1), 10) = "口人員口地點口功能"
xD(T1 & "/s") = xD(T1 & "/s") + Arr(i, 12) '數量小計
xD(T1 & "/c") = Crr
i01: Next i
'--------------------------------
Application.ScreenUpdating = False
Set xA = [盤點表!A1]
For i = 1 To N
If i > 1 Then [盤點表!A1:j3].Copy xA
T1 = xD(i): R = xD(T1): Crr = xD(T1 & "/c")
xA(2, 2) = T1: xA(2, 10) = "頁次：" & i & "/" & N
With xA(4).Resize(R, 10)
      [盤點表!a4:j4].Copy .Cells
      .Value = Crr
End With
xA(R + 4, 5) = "小計": xA(R + 4, 8) = xD(T1 & "/s")
Set xA = xA(R + 5)
xA.PageBreak = xlPageBreakManual '設定分頁線
Next i
Set xD = Nothing: Erase Arr, Brr, Crr
MsgBox Timer - tm
End Sub

TOP

准提部林