返回列表 上一主題 發帖

[發問] 橫式資料轉換為直式資料_各梯次名單

[發問] 橫式資料轉換為直式資料_各梯次名單

本帖最後由 Andy2483 於 2022-12-2 15:38 編輯

各位前輩好
後學想學習各種不同vba寫法,請各位前輩指導!謝謝
後學藉 aer前輩的主題範例作為題材,謝謝 aer前輩,如有冒犯 請見諒
不同主題另開題作學習
http://forum.twbts.com/viewthrea ... a=pageD1&page=1
報名轉檔.zip 範例如上論壇鏈結

請將範例處理成為梯次名單(梯次橫向排序,各梯名單各自排序)如下圖


後學的程式碼如下:
Option Explicit
Sub TEST_直式梯次名單()
Dim Arr, Brr, xR, i&, j&, S&, N&, M&, R&, C&
Dim Y, D As Date
Set Y = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
   .Replace What:=" ", Replacement:="", LookAt:=xlPart
   .Sort KEY1:=.Item(1), Order1:=1, Header:=1
   Arr = .Value
   Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
   .Clear
End With
For Each xR In Brr
   If Trim(xR) <> "" Then
      S = InStr(xR, "梯") + 1
      N = InStr(xR, "(")
      D = Mid(xR, S, N - S)
      Y(D) = Trim(xR)
   End If
Next
[Sheet3!A1].Resize(Y.Count, 1) = Application.Transpose(Y.KEYS)
[Sheet3!B1].Resize(Y.Count, 1) = Application.Transpose(Y.ITEMS)
With Sheets("Sheet3").UsedRange
   .Sort KEY1:=.Item(1), Order1:=1, Header:=2
   Brr = .Value
   .Clear
End With
Y.RemoveAll
For i = 1 To UBound(Brr)
   M = M + 1
   Y(Brr(i, 2)) = M
Next
ReDim Brr(1 To UBound(Arr), 1 To Y.Count)
For i = 2 To UBound(Arr)
   For j = 2 To UBound(Arr, 2)
      If Arr(i, j) <> "" Then
         R = Y(Arr(i, j) & "|")
         R = R + 1
         C = Y(Arr(i, j) & "")
         Brr(R, C) = Arr(i, 1)
         Y(Arr(i, j) & "|") = R
      End If
   Next j
Next i
[Sheet3!A1].Resize(1, M) = Application.Transpose(Application.Transpose(Y.KEYS))
[Sheet3!A2].Resize(UBound(Brr), M) = Brr
Application.Goto [Sheet3!A1]
Set Arr = Nothing
Set Arr = Nothing
Set Y = Nothing
End Sub

PS:後學星期六.日不方便回復前輩,請見諒,星期一早上回復

糗了!沒處理重複的名單!
請各位前輩指導!謝謝

TOP

google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

本帖最後由 Andy2483 於 2022-12-5 11:22 編輯

回復 3# hcm19522


    謝謝前輩指導 OFFSET() 的用法


後學學習心得如下,請前輩再指導!謝謝
H1=OFFSET($A$1,COLUMN(A1),ROW(A1)-1)&""
令[H1]儲存格的值是:固定標的儲存格[A1] 偏移位置格的值, 再連接空字元 的值(以免標空白的目標格,讓結果格值顯示 0)

1.$A$1是一個固定位址的儲存格; $A是固定欄位的意思; $1是列位固定的意思
1.1.其他如 $A1:是欄位固定,列位不固定的意思
1.2.其他如 A$1:是欄位不固定,列位固定的意思
1.3.其他如 A1:是欄位不固定,列位也不固定的意思

2..偏移位置格的值
2.1.[A1]儲存格偏移往下偏移  COLUMN(A1) 列數:[A1]自身的欄位就是 1
2.2.[A1]儲存格偏移往橫向偏移 ROW(A1)-1 欄位:[A1]自身的列位是 1,減掉1變成 0(不偏移的意思)
https://support.microsoft.com/zh-tw/office/offset-%E5%87%BD%E6%95%B8-c8de19ae-dd79-4b9b-a14e-b4d906d11b66
=OFFSET($A$1,0,0)  結果>>        第1梯
=OFFSET($A$1,1,0)  結果>>        A1

3.把列位與欄位參數化!讓欄數與列數對調,呈現出想要的值,再[H1]複製到[H1:T5]這些結果格,就會產生轉置的效果

TOP

本帖最後由 hcm19522 於 2022-12-5 13:42 編輯

回復 4# Andy2483

學習精神可嘉 按個讚

OFFSET(儲存格名稱,上下移動數,左右移動數,上下區間數,左右區間數)  整欄或整列 後二參數可省掉

  後面 &""-->儲存格若為空 則空 否則為 0

https://blog.xuite.net/hcm19522/twblog/590645095
google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

本帖最後由 Andy2483 於 2022-12-6 16:54 編輯

今天練習多個字典與陣列,排除資料表重複列_整理成直式梯次名單_方式:先整理再排序
以下是結果,請各位前輩指導!謝謝
邀請大家一起上論壇學習!討論!
執行結果:


PS:有兩個 高O芬 不同梯次
Option Explicit
Sub TEST_排除資料表重複列_直式梯次名單_先整理再排序()
Dim Brr, Crr, xR, Z, xA, V, W, P, Sh1, SH3
Dim i&, j&, S&, N&, R&, C&, X&, Y&, Q&
Dim D As Date, Da$, T$
Set W = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set P = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1")
Set SH3 = Sheets("Sheet3")
SH3.UsedRange.Clear
Crr = Range(Sh1.[A1], Sh1.UsedRange).Offset(1, 0)
R = UBound(Crr) - 1
C = UBound(Crr, 2)
ReDim Brr(1 To R, 1 To C)
ReDim V(R - 1)
For i = 1 To R
   Da = ""
   For j = 1 To C
      Da = Da & "/" & Crr(i, j)
   Next
   If W.Exists(Da) = Empty Then
      Q = Q + 1
      For j = 1 To C
         Brr(Q, j) = Trim(Crr(i, j))
      Next
      W(Da) = ""
   End If
Next
W.RemoveAll
For Each xR In Brr
   If InStr(xR, "(") Then
      S = InStr(xR, "梯") + 1
      N = InStr(xR, "(")
      D = Mid(xR, S, N - S)
      W(D) = xR
      P(xR) = D
   End If
Next
For Each xA In W.KEYS
   Z(xA) = V
Next
For i = 1 To Q
   For j = 2 To C
      T = Brr(i, j)
      If T <> "" Then
         V = Z(P(T))
         X = W(T & "|") + 1
         V(X - 1) = Brr(i, 1)
         W(T & "|") = X
         Z(P(T)) = V
      End If
   Next j
Next i
SH3.[A1].Resize(1, Z.Count) = Application.Transpose(Application.Transpose(Z.KEYS))
SH3.[A2].Resize(Q, Z.Count) = Application.Transpose(Z.ITEMS)
For i = 1 To SH3.UsedRange.Columns.Count
   With Range(SH3.Cells(1, i), SH3.Cells(Rows.Count, i).End(3))
      .Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
   End With
Next
With SH3.UsedRange
   .Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlLeftToRight
   For i = 1 To .Columns.Count
      D = .Cells(1, i)
      .Cells(1, i) = W(D)
   Next
End With
Application.Goto [Sheet3!A1]
Set Crr = Nothing
Set Brr = Nothing
Set W = Nothing
Set Z = Nothing
Set P = Nothing
End Sub

TOP

謝謝論壇
今天自己註解程式碼質疑了自己是否真懂每個陳述.涵式...,還是只會抄襲
item() :會依位置或按鍵傳回 集合 物件的特定 成員。
https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/item-method-visual-basic-for-applications
以下是#6樓的心得註解

Option Explicit
Sub TEST_排除資料表重複列_直式梯次名單_先整理再排序()
Dim Brr, Crr, xR, Z, xA, V, W, P, Sh1, SH3
'↑宣告通用型變數
Dim i&, j&, S&, N&, R&, C&, X&, Y&, Q&
'↑宣告長整數變數
Dim D As Date, Da$, T$
'↑宣告變數!(D)是日期變數,(Da,T)是字串變數
Set W = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set P = CreateObject("Scripting.Dictionary")
'↑令W,Z,P各是字典
Set Sh1 = Sheets("Sheet1")
'↑令Sh1是 "Sheet1" 工作表
Set SH3 = Sheets("Sheet3")
'↑令Sh1是 "Sheet3" 工作表
SH3.UsedRange.Clear
'↑令 "Sheet3" 工作表涵蓋有使用的儲存格最小方正區域清除
Crr = Range(Sh1.[A1], Sh1.UsedRange).Offset(1, 0)
'↑令Crr是 表1[A1]到有使用儲存格的最小方正範圍儲存格往下偏移1列範圍的值
R = UBound(Crr) - 1
'↑令R是 Crr陣列縱向最大列號數減 1
C = UBound(Crr, 2)
'↑令C是 Crr陣列橫向最大列號數
ReDim Brr(1 To R, 1 To C)
'↑宣告Brr陣列範圍!縱向從1到R,橫向從1到C
ReDim V(R - 1)
'↑宣告V是一維陣列!索引範圍從0到R - 1
For i = 1 To R
'↑設外順迴圈!i從1到R
   Da = ""
   '↑令Da字串變數是空字元
   For j = 1 To C
   '↑設內順迴圈!j從1到C
      Da = Da & "/" & Crr(i, j)
      '↑令Da字串變數是 自己連接"/"符號,再連接i迴圈列j迴圈欄的Crr陣列值
   Next
   If W.Exists(Da) = Empty Then
   '↑如果以Da當key查察W字典裡是初始值
      Q = Q + 1
      '↑令Q變數累加1
      For j = 1 To C
      '↑設內順迴圈!j從1到C
         Brr(Q, j) = Trim(Crr(i, j))
         '↑令Q變數列第j迴圈欄的Brr陣列值是 i迴圈列第迴圈j欄的值去掉頭尾的空白字元
      Next
      W(Da) = ""
      '↑令以Da字串變數值當key,item是空字元倒入W字典裡
   End If
Next
W.RemoveAll
'↑清空W字典
For Each xR In Brr
'↑設順迴圈!令xR 是Brr陣列的一員
   If InStr(xR, "(") Then
   '↑如果xR值裡有包含"("符號?
      S = InStr(xR, "梯") + 1
      '↑令S是xR判斷 "梯"字元所在字元位置數
      N = InStr(xR, "(")
      '↑令N 是 xR判斷 "("字元所在字元位置數
      D = Mid(xR, S, N - S)
      '↑令D是 xR值從S字元開始取 N - S個字的字串再變為日期
      W(D) = xR
      '↑令D這日期當key,item是xR的值
      P(xR) = D
      '↑令xR這日期當key,item是D的值
   End If
Next
For Each xA In W.KEYS
'↑設順迴圈!令xA 是W字典裡keys的一員
   Z(xA) = V
   '↑令以xA為key,item是V一維陣列,倒入Z字典裡
Next
For i = 1 To Q
'↑設外順迴圈!i從1到Q
   For j = 2 To C
   '↑設內順迴圈!j從1到Q
      T = Brr(i, j)
      '↑令T字串變數是i迴圈列j迴圈欄的Brr陣列值
      If T <> "" Then
      '↑如果T字串變數不等於空字元??
         V = Z(P(T))
         '↑令V這通用型變數是 以T字串查察P字典的item值再查察Z字典得到的item(一維陣列)
         X = W(T & "|") + 1
         '↑令X這數字變數是 以T字串連接"|"符號查察字典的item值累加 1
         V(X - 1) = Brr(i, 1)
         '↑令V這一維陣列的索引號是 X-1的元素是 是i迴圈列第一欄的Brr陣列值
         W(T & "|") = X
         '↑令以T字串連接"|"符號為key的item是 數字變數X
         Z(P(T)) = V
         '↑令以T字串查察P字典的item值再查察Z字典得到的item是 一維陣列V
      End If
   Next j
Next i
SH3.[A1].Resize(1, Z.Count) = Application.Transpose(Application.Transpose(Z.KEYS))
'↑令表三[A1]擴展向下擴展1列(A1自身列),向右擴展Z字典鍵數欄是 Z字典key轉置兩次的值
SH3.[A2].Resize(Q, Z.Count) = Application.Transpose(Z.ITEMS)
'↑令表三[A2]擴展向下擴展 Q列,向右擴展Z字典鍵數欄是 Z字典key轉置兩次的值
For i = 1 To SH3.UsedRange.Columns.Count
'↑設順迴圈!i從1到 表三使用範圍的欄數
   With Range(SH3.Cells(1, i), SH3.Cells(Rows.Count, i).End(3))
   '↑以下是有關於表三 每一欄有內容的儲存格程序
      .Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
      '↑排序:基準是範圍裡第一格欄位,大到小,沒有標題列,縱向排序從上到下
   End With
Next
With SH3.UsedRange
'↑以下是有關於表三使用範圍的儲存格程序
   .Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlLeftToRight
   '↑排序:基準是範圍裡第一格列位,大到小,沒有標題列,縱向排序從左到右
   For i = 1 To .Columns.Count
   '↑設順迴圈!i從1 到表三使用範圍的欄數
      D = .Cells(1, i)
      '↑令D日期變數是 表三使用範圍的相對儲存格第1列第i迴圈變數欄的值轉成日期
      .Cells(1, i) = W(D)
      '↑令以 表三使用範圍的相對儲存格第1列第i迴圈變數欄的值查察W字典得到的item值(字串)
      '的值放入當格

   Next
End With
Application.Goto [Sheet3!A1]
Set Crr = Nothing
Set Brr = Nothing
Set W = Nothing
Set Z = Nothing
Set P = Nothing
End Sub

Sub Item的規則()
Dim Area As Range
Set Area = [A1:J10]
MsgBox Area.Item(1).Address
MsgBox Area.Item(5).Address
MsgBox Area.Item(10).Address
MsgBox Area.Item(11).Address
MsgBox Area.Item(100).Address
MsgBox Area.Item(101).Address
'↑範圍內由左到右,上到下標儲存格索引
MsgBox Area.Item(1, 1).Address
MsgBox Area.Item(1, 5).Address
MsgBox Area.Item(1, 10).Address
MsgBox Area.Item(2, 1).Address
MsgBox Area.Item(10, 10).Address
MsgBox Area.Item(1, 11).Address
'↑範圍內的座標方式標儲存格索引
End Sub

TOP

回復 7# Andy2483


感覺好像有一招
準大還有其他大大常用的做法
字典嵌套 或 字典合併key值(列號+關鍵字)
可以縮短程序
若要取出列號 再用replace把關鍵字移掉

TOP

本帖最後由 Andy2483 於 2022-12-8 07:28 編輯
回復  Andy2483


感覺好像有一招
準大還有其他大大常用的做法
字典嵌套 或 字典合併key值(列號+關鍵 ...
singo1232001 發表於 2022-12-7 22:36



    謝謝前輩指點
後學(厚臉皮的學生)來研究一下!
可是前輩說的方式很魔法,可以再多提示一點嗎?
懇請前輩秀上您的方案嗎?
哪一帖有這種魔法招式?請前輩再提點一下!
拜託!

TOP

回復 1# Andy2483

您寫得很好了,參考您的修改一下,謝謝

Sub test()
Dim Arr, Brr, Crr, xD, xR, i&, j&, S&, N&, M&, R&, C&, D As Date
Set xD = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
    .Replace What:=" ", Replacement:="", LookAt:=xlPart
    .Sort Key1:=.Item(1), Order1:=1, Header:=1
    Arr = .Value
    Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
    .Clear
End With
ReDim Crr(1 To UBound(Arr), 1 To 2)
For Each xR In Brr
    If InStr(xR, "梯") Then
        S = InStr(xR, "梯") + 1
        N = InStr(xR, "(")
        D = Mid(xR, S, N - S)
        If Not xD.Exists(D) Then
            i = i + 1: xD(D) = i
            Crr(i, 1) = D: Crr(i, 2) = Trim(xR)
        End If
    End If
Next
With Sheets("Sheet3").[a1].Resize(i, 2)
        .Value = Crr
        .Sort Key1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
        Brr = .Value
        .Clear
End With
xD.RemoveAll
ReDim Crr(1 To UBound(Arr), 1 To i)
For i = 1 To UBound(Brr)
   M = M + 1: xD(Brr(i, 2)) = M
   Crr(1, M) = Brr(i, 2)
Next
For i = 2 To UBound(Arr)
   For j = 2 To UBound(Arr, 2)
      If Arr(i, j) <> "" Then
        If Not xD.Exists(Arr(i, j) & "|" & Arr(i, 1)) Then
            R = xD(Arr(i, j) & "|R")
            If R = 0 Then R = R + 2 Else R = R + 1
            C = xD(Arr(i, j) & "")
            Crr(R, C) = Arr(i, 1)
            xD(Arr(i, j) & "|R") = R
            xD(Arr(i, j) & "|" & Arr(i, 1)) = ""
         End If
      End If
   Next j
Next i
[Sheet3!A1].Resize(UBound(Crr), M) = Crr
Application.Goto [Sheet3!A1]
End Sub

TOP

        靜思自在 : 人要自愛,才能愛普天下的人。
返回列表 上一主題