1234
返回列表 上一主題 發帖

[發問] 請教 以字典抓取符合條件資料後輸出

shuo1125

帖子
121 
主題
8 
精華
0 
積分
170 
點名
45  
作業系統
win10 
軟體版本
Office2016 
閱讀權限
20 
性別
男 
註冊時間
2021-1-21 
最後登錄
2024-4-10 
21# 跳轉到 »
發表於 2021-12-9 21:43 | 只看該作者
回復 19# 准提部林

准大好！

附上圖
J欄.png
2021-12-9 21:40

不好意思再請教個問題...如果有資料的部分J欄想增加"口人員 口地點 口功能"這些文字
請問該如何修改好，可煩請再指導一下嗎?

勞煩您抽空解答了，謝謝。

TOP

准提部林

帖子
2798 
主題
10 
精華
0 
積分
2854 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-4-15 
22#
發表於 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

shuo1125

帖子
121 
主題
8 
精華
0 
積分
170 
點名
45  
作業系統
win10 
軟體版本
Office2016 
閱讀權限
20 
性別
男 
註冊時間
2021-1-21 
最後登錄
2024-4-10 
23#
發表於 2021-12-10 21:02 | 只看該作者
回復 22# 准提部林
准大好！
不好意思...好像有點怪怪的
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
'好像沒有上述這一段...
----------------------------------------------------------------------------------------------------------------
    Set xA = [盤點表單!A1]
For i = 1 To N
    If i > 1 Then [盤點表單!A1:K3].Copy xA
    T1 = xD(i): R = xD(T1): Crr = xD(T1 & "/c")
    xA(2, 2) = T1: xA(2, 11) = "項次：" & i & "/" & N
    With xA(4).Resize(R, 11)
         [盤點表單!A4:K4].Copy .Cells
         .Value = Crr
    End With
    xA(R + 4, 2) = "會盤人：": xA(R + 4, 4) = "盤點人：": xA(R + 4, 5) = "小計": xA(R + 4, 9) = xD(T1 & "/s")
    Set xA = xA(R + 5)
    xA.PageBreak = xlPageBreakManual '設定分頁線
'是上面這段
----------------------------------------------------------------------------------------------------------------
還是我放的位置有錯...麻煩在指正一下
勞煩你了，謝謝。

TOP

准提部林

帖子
2798 
主題
10 
精華
0 
積分
2854 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-4-15 
24#
發表於 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

准提部林

帖子
2798 
主題
10 
精華
0 
積分
2854 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-4-15 
25#
發表於 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

shuo1125

帖子
121 
主題
8 
精華
0 
積分
170 
點名
45  
作業系統
win10 
軟體版本
Office2016 
閱讀權限
20 
性別
男 
註冊時間
2021-1-21 
最後登錄
2024-4-10 
26#
發表於 2021-12-10 21:22 | 只看該作者
回復 25# 准提部林
准大好！

可以了，謝謝你屢次不吝的完整回答..

感激不盡，祝您順心~

TOP

shuo1125

帖子
121 
主題
8 
精華
0 
積分
170 
點名
45  
作業系統
win10 
軟體版本
Office2016 
閱讀權限
20 
性別
男 
註冊時間
2021-1-21 
最後登錄
2024-4-10 
27#
發表於 2022-2-11 13:53 | 只看該作者
回復 25# 准提部林

准大好！
抱歉再追問...
請問若我希望呈現結果為每頁都有抬頭及標題，
程式碼該如何修正？
附上附檔及圖片(因有機密資料故附檔為範例)
麻煩在抽空協助了，感激不盡！
結果.PNG

資產測試資料.zip (786.77 KB)

TOP

准提部林

帖子
2798 
主題
10 
精華
0 
積分
2854 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-4-15 
28#
發表於 2022-2-13 14:53 | 只看該作者
本帖最後由 准提部林 於 2022-2-13 14:55 編輯

回復 27# shuo1125

這種列印方法, 非常麻煩, 只以目前的列印設定為準, 表首3行+表身27行--為一頁,
若有變動, 自行去調整(先調整列印設定, 再去抓表身行數)
Xl0000261-1.rar (678.25 KB)

列印設定如果放在程式中, 速度會變得很久, 有時久到像當機, 最好避免, 應手動事先設好設滿~~讓程式只處理數據就好
程式增加三欄輔助(執行後自動清除)--作為排序及表首+頁次的處理, 否則執行太慢~~

TOP

shuo1125

帖子
121 
主題
8 
精華
0 
積分
170 
點名
45  
作業系統
win10 
軟體版本
Office2016 
閱讀權限
20 
性別
男 
註冊時間
2021-1-21 
最後登錄
2024-4-10 
29#
發表於 2022-2-13 16:43 | 只看該作者
回復 28# 准提部林

准大好！
其實是後來想到在實際列印紙本清點時，
沒有抬頭真的會不太好看...但又想不出如何調整...
沒想到您幫忙之餘還能想到程式運行速度及調整內容，
真是太專業了，但程式碼我還需花時間研究一下...
若有問題屆時再勞煩你不吝指導了，
謝謝！

TOP

shuo1125

帖子
121 
主題
8 
精華
0 
積分
170 
點名
45  
作業系統
win10 
軟體版本
Office2016 
閱讀權限
20 
性別
男 
註冊時間
2021-1-21 
最後登錄
2024-4-10 
30#
發表於 2022-9-20 11:15 | 只看該作者
回復 28# 准提部林
准大好！
經前段您指導的程式碼，我修改成符合使用後遇到以下問題，可否煩請抽空協助指導如何修正...
問題A→B2=預算總額-請購總額。
問題B→小計部分的請購總額及未給付總額有辦法得出嗎?(因請購單會有重複之狀況。)
或是有其他前輩可抽空指導…
以上，麻煩大家了！
若文字敘述不清，可看附檔及圖檔。
問題.PNG
2022-9-20 11:05
Beta20220916.zip (53.89 KB)

TOP

        靜思自在 : 不要小看自己，因為人有無限的可能。
1234
返回列表 上一主題