- 帖子
- 1446
- 主題
- 40
- 精華
- 0
- 積分
- 1470
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-10-21
|
20#
發表於 2022-12-6 11:44
| 只看該作者
本帖最後由 Andy2483 於 2022-12-6 11:51 編輯
回復 14# 准提部林
再次謝謝 准提部林前輩指導
再次謝謝 b9208前輩發表此主題與範例
後學藉此帖練習以字典的一維陣列ITEM轉置成結果,得很多知識,謝謝論壇
這範例用 准提部林前輩的程式架構再多一個字典與一維陣列做變化,結果稍有不同
執行細節與心得註解如下,請前輩再指導!謝謝
執行後:
Option Explicit
Sub TEST_總表_轉置()
Dim Arr, Y, Z, Q, PH$, FN$, i&, j&, V$(14)
'↑宣告(Arr, Y, Z, Q)是通用型變數,(PH$, FN$)是字串變數,(i,j)是長整數變數,
'V是15個元素的一維字串陣列變數
Dim xB As Workbook, xS As Worksheet, TT$, T$(4), M&
'↑宣告(xB)是活頁簿變數,(xS)是工作表變數,
'(TT)是字串變數,T是5個元素的一維字串陣列變數,(M&)是長整數變數
Set Y = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
'↑令Y,Z 各是字典
PH = ThisWorkbook.Path
'↑令PH字串變數是 現在這活頁簿的所在檔案位置
Call 清除_總表1
'↑執行 副程式 清除_總表1()
'--------------------------
Arr = Range([總表!a1], [總表!a65536].End(xlUp))
'↑令Arr是陣列!倒入"總表"工作表[A1]到"總表"工作表A欄最後一個有內容的儲存格
For i = 2 To UBound(Arr)
'↑設順迴圈i從2 到Arr陣列縱向最大列號
If Arr(i, 1) <> "" Then Y(Arr(i, 1) & "//a") = 1
'↑如果Arr陣列迴圈列第一欄的值不是 空字元!
'就以Arr陣列迴圈列第一欄的值 連接 "//a" 字串 當Y字典的KEY,
'item是數字1
Next i
Application.ScreenUpdating = False
'↑螢幕畫面不跟著執行程序變化
Do
'↑設無限迴圈!開始執行後面的程序,自己想辦法跳出迴圈
If FN = "" Then
'↑如果FN字串變數是 空字元??
FN = Dir(PH & "\*.xls")
'↑令FN字串變數是 現在這活頁簿的所在檔案位置的EXCEL檔案
Else
FN = Dir
'↑FN逐次抓取相同路徑下的當名
'https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/dir-function
End If
If FN = "" Then Exit Do
'↑如果FN字串變數是空字元!代表相同路徑下的檔名已經都抓過了,就跳出Do~Loop的迴圈
If FN = ThisWorkbook.Name Then GoTo DP
'↑如果FN字串變數是 現在這活頁簿的名稱字串!就跳到 DP 位置繼續執行
'--------------------------
Set xB = Workbooks.Open(PH & "\" & FN, ReadOnly:=True)
'↑令xB 是以唯讀方式打開 PH字串變數 & "\" & FN字串變數組合成字串的活頁簿
Set xS = xB.Sheets(1)
'↑令xS 是打開的這活頁簿的第一個工作表
Arr = Range(xS.[A1:O1], xS.UsedRange)
'↑令Arr倒掉原來的陣列值!變成新陣列,倒入打開的活頁簿第一個表全部有使用的儲存格值
'xS.UsedRange有可能不包含最左上角的儲存格!所以用 xS.[A1:O1]在前方做完整區域儲存格匡列
For i = 6 To UBound(Arr)
'↑設外順迴圈!i從6到Arr陣列縱向最大列號
T(1) = Arr(i, 6)
'↑令T一維陣列的第二個字串是i迴圈數第六欄Arr陣列值
T(2) = Arr(i, 8)
'↑令T一維陣列的第三個字串是i迴圈數第八欄Arr陣列值
T(3) = Left(Arr(i, 9), 7)
'↑令T一維陣列的第四個字串是i迴圈數第九欄Arr陣列值的左邊7個字元
T(4) = Arr(i, 3)
'↑令T一維陣列的第五個字串是i迴圈數第三欄Arr陣列值
If T(1) = "" Or Y(T(1) & "//a") = 0 Then
'↑如果T陣列的第二個字串是 空字元 或
'以 T陣列的第二個字串連接 "//a"字串查察Y字典 是0??
GoTo 101
'↑條件成立!就跳到 101的位置繼續執行
End If
TT = T(1) & "|" & T(2) & "|" & T(3) & "|" & T(4)
'↑令TT字串變數是T陣列裡第二個字串到第五個字串中間連接"|"符號的字串
If Y.Exists(TT) = Empty Then
'↑如果 用TT字串變數查察Y字典沒有這個key
Y(TT) = Arr(i, 11)
'↑令TT字串變數是key,item是迴圈列數第11欄的Arr陣列值,倒入Y字典裡
ElseIf Arr(i, 11) > Y(TT) Then
'↑否則如果 迴圈列數第11欄的Arr陣列值 大於 (TT當key查察Y字典的item值)
Y(TT) = Arr(i, 11)
'↑令TT字串變數是key,item是迴圈列數第11欄的Arr陣列值,倒入Y字典裡,
'如果key重複!就將item置換成新的
Z.Remove TT
'↑令Z字典刪除 TT字串變數的key與item
M = M - 1
'↑令M減掉 1
End If
If Z.Exists(TT) = Empty Then
M = M + 1
'↑令M累加1
Q = V
'↑令Q 是V一維陣列
For j = 0 To UBound(Q)
'↑設內順迴圈!j從0 到Q陣列橫向最大欄號
Q(j) = Arr(i, j + 1)
'↑令 j內迴圈索引號的Q陣列值 = 外迴圈i列號 j+1內迴圈欄號的Arr陣列值
Next
Q(8) = Left(Q(8), 7)
'↑8索引號的Q陣列值 = 自己的值取左側的7 個字元
Z(TT) = Q
'↑令TT字串變數為key,Item是Q一維陣列
End If
101: Next i
xB.Close 0
'↑關閉被開啟的 xB活頁簿變數檔案(不存檔)
DP: Loop
'↑無限迴圈的轉折點!跳到前面的Do位置繼續執行!
'--------------------------
If M > 0 Then
'↑如果M整數變數大於0 (這裡的M 指的是 Z字典key數量)
With [總表!b6].Resize(M, UBound(V) + 1)
'↑以下關於 "總表"工作表[B6]向下擴展M列,向右擴展Q陣列最大索引號+1數欄 的儲存格區域
.Value = Application.Transpose(Application.Transpose(Z.items))
'↑這擴展區域儲存格以Z字典的items轉置兩次的值倒入
.Borders.LineStyle = 1
'↑令這擴展區域儲存格的格線樣式是 細實線
.Sort key1:=.Item(3), Order1:=xlAscending, _
key2:=.Item(8), Order2:=xlAscending, Header:=xlNo
'↑這擴展區域儲存格做兩層次的整列排序,細節如下:
'1.將這擴展區域儲存格的相對第三欄位(表裡的 D欄),做小到大的排序
'2.並將一次排序後裡面相同值的相對第八欄位(表裡的 I欄),做小到大的排序
End With
End If
Set Arr = Nothing: Set Y = Nothing: Set Z = Nothing
Erase V, T, Q
End Sub
Sub 清除_總表1()
Sheets("總表").UsedRange.Offset(5, 0).Offset(, 1).Delete Shift:=xlUp
'↑"總表"工作表有使用的儲存格範圍,往下偏移5列,左右不偏移,之後再往右偏移1欄,
'此儲存格範圍刪除!並由下方的儲存格往上遞補
'Offset(5, 0).Offset(, 1) = Offset(5, 0).Offset(0 , 1)
'Offset(5, 0).Offset(, 1) = Offset(5).Offset( , 1)
'Offset(5, 0).Offset(, 1) = Offset(5, 1)
'Offset(5, ).Offset(, 1) 會出現 編譯錯誤
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.range.offset
End Sub |
|
發表於 2020-12-16 10:54
| 
