資料轉置求助前輩(頁 1) - Excel程式區

dou10801 發表於 2021-6-10 12:27

資料轉置求助前輩

資料轉置求助前輩,如何直式轉橫式分上下半年,懇請先進幫忙,感恩.

singo1232001 發表於 2021-6-10 14:21

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115280&ptid=23162]1#[/url] [i]dou10801[/i] [/b]

samwang 發表於 2021-6-10 16:34

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115280&ptid=23162]1#[/url] [i]dou10801[/i] [/b]

請測試看看，謝謝。

Sub test()
Dim Arr, Brr(), i&, s%, k%, n%, x%
Arr = Range([a3], [c65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 16)
For i = 1 To UBound(Arr)
s = s + 1: k = k + 1
For j = 1 To 3
      n = n + 1: Brr(n, k) = Arr(i, j)
Next j
If s = 16 Then
      x = x + 1: R = R + s
      n = R / 16 * 3 + x
      k = 0: s = 0
Else
      If n < 4 Then n = 0 Else n = n - 3
End If
Next
Range("h12").Resize((x + 1) * 4, 16) = Brr
End Sub

samwang 發表於 2021-6-10 17:31

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115281&ptid=23162]2#[/url] [i]singo1232001[/i] [/b]

大大您好，如果資料來源在多加幾列，結果顯示會不一樣，請再測試看看，謝謝。

singo1232001 發表於 2021-6-10 23:59

有出狀況的範例嗎

samwang 發表於 2021-6-11 06:09

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115284&ptid=23162]5#[/url] [i]singo1232001[/i] [/b]

如附件請您測試看看，謝謝。

准提部林 發表於 2021-6-11 09:40

Sub 轉置()
Dim Arr, Brr, C%(2), r%, i&, j%
ActiveSheet.UsedRange.Offset(, 7).EntireColumn.Delete
Arr = Range([a3], [c65536].End(3))
ReDim Brr(1 To 8, 1 To 200)
For i = 2 To UBound(Arr)
r = IIf(Arr(i, 1) > 6, 1, 0):  C(r) = C(r) + 1
For j = 1 To 3
      Brr(r * 4 + j, C(r)) = Arr(i, j)
Next j
If C(r) > C(2) Then C(2) = C(r)
Next i
With [h2].Resize(UBound(Brr), C(2))
   .Value = Brr
   .Borders.LineStyle = 1
   .ColumnWidth = 4
   .Font.Size = 14
End With
End Sub

[attach]33384[/attach]

================================

hcm19522 發表於 2021-6-11 10:01

[url]https://blog.xuite.net/hcm19522/twblog/589826553[/url]

singo1232001 發表於 2021-6-11 14:29

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115285&ptid=23162]6#[/url] [i]samwang[/i] [/b]

samwang 發表於 2021-6-11 16:16

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115289&ptid=23162]9#[/url] [i]singo1232001[/i] [/b]

# 3 樓回答，應該就是您的需求，請再測試看看，謝謝。
Sub test()
Dim Arr, Brr(), i&, s%, k%, n%, x%
Arr = Range([a3], [c65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 16)
For i = 1 To UBound(Arr)
   s = s + 1: k = k + 1
   For j = 1 To 3
      n = n + 1: Brr(n, k) = Arr(i, j)
   Next j
   If s = 16 Then
      x = x + 1: R = R + s
      n = R / 16 * 3 + x
      k = 0: s = 0
   Else
      If n < 4 Then n = 0 Else n = n - 3
   End If
Next
Range("[color=Red]h2[/color]").Resize((x + 1) * 4, 16) = Brr
End Sub

dou10801 發表於 2021-6-19 09:10

感謝各方前輩指點,收下慢慢學習.

Andy2483 發表於 2023-6-2 13:17

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115286&ptid=23162]7#[/url] [i]准提部林[/i] [/b]

謝謝論壇,謝謝前輩
後學藉此帖學習前輩的方案,方案學習心得註解如下,請前輩再指導

執行前:
[attach]36505[/attach]

執行結果:
[attach]36506[/attach]

Sub 轉置()
Dim Arr, Brr, C%(2), r%, j%, i&
[color=SeaGreen]'↑宣告變數:(Arr,Brr)是通用型變數,C是短整數值的一維陣列(0~2)[/color]
[color=SeaGreen]'(r,j)是短整數,i是長整數[/color]
ActiveSheet.UsedRange.Offset(, 7).EntireColumn.Delete
[color=SeaGreen]'↑令使用的儲存格往右偏移7欄範圍儲存格所在的欄位刪除[/color]
Arr = Range([a3], [c65536].End(3))
[color=SeaGreen]'↑令Arr變數是二維陣列,以[A3]到C欄最後一個有內容儲存格值帶入[/color]
ReDim Brr(1 To 8, 1 To 200)
[color=SeaGreen]'↑令Brr變數是二維空陣列,縱向範圍1~8,橫向範圍1~200[/color]
For i = 2 To UBound(Arr)
[color=SeaGreen]'↑設順迴圈[/color]
r = IIf(Arr(i, 1) > 6, 1, 0):  C(r) = C(r) + 1
[color=SeaGreen] '↑令r變數是IIf()回傳值,如果第1欄Arr陣列值大於6,回傳1,否則0
'↑令r索引號的C陣列值累加1[/color]
For j = 1 To 3
[color=SeaGreen] '↑設順迴圈[/color]
      Brr(r * 4 + j, C(r)) = Arr(i, j)
[color=SeaGreen]       '↑令Arr陣列值寫入Brr陣列指定位置裡[/color]
Next j
If C(r) > C(2) Then C(2) = C(r)
[color=SeaGreen] '↑如果r變數索引號C陣列值大於 2索引號C陣列值,
'就令2索引號C陣列值是 r變數索引號C陣列值
'C(2)是為了計算陣列最大需求欄數[/color]
Next i
With [h2].Resize(UBound(Brr), C(2))
   .Value = Brr
[color=SeaGreen]    '↑令儲存格值以Brr陣列帶入[/color]
   .Borders.LineStyle = 1
[color=SeaGreen]    '↑令儲存格框線是細實線[/color]
   .ColumnWidth = 4
[color=SeaGreen]    '↑令儲存格欄寬是 4[/color]
   .Font.Size = 14
[color=SeaGreen]    '↑令儲存格字大小是 4[/color]
End With
End Sub

Andy2483 發表於 2023-6-2 14:55

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

Option Explicit
Sub TEST()
Dim Brr, Crr, Y, R%, i&, j%, T%
[color=SeaGreen]'↑宣告變數[/color]
Set Y = CreateObject("Scripting.Dictionary")
[color=SeaGreen]'↑令Y變數是字典[/color]
Range([H1], Cells(1, Columns.Count)).EntireColumn.Delete
[color=SeaGreen]'↑令H欄到最後欄刪除[/color]
Brr = Range([C3], [A65536].End(3))
[color=SeaGreen]'↑令Brr變數是二維陣列,以[A3]到C欄最後一個有內容儲存格值帶入[/color]
ReDim Crr(1 To 8, 1 To 200)
[color=SeaGreen]'↑令Crr變數是二維空陣列,縱向範圍1~8,橫向範圍1~200[/color]
Y("上區") = 0: Y("下區") = 4
[color=SeaGreen]'↑令"上區"字串當key,item是 0;令"下區"字串當key,item是 4:納入Y字典裡[/color]
For i = 1 To UBound(Brr)
[color=SeaGreen]'↑設順迴圈[/color]
T = Brr(i, 1)
[color=SeaGreen] '↑令T變數是第1欄Brr陣列值[/color]
R = IIf(T > 6, Y("下區"), Y("上區")): Y(R) = Y(R) + 1
[color=SeaGreen] '↑令R變數是IIf()回傳值,如果T變數大於6,回傳4,否則0
'↑令在Y字典裡0或4的key,其item值累加1(紀錄欄最後索引號)[/color]
For j = 1 To 3
[color=SeaGreen] '↑設順迴圈[/color]
      Crr(R + j, Y(R)) = Brr(i, j)
[color=SeaGreen]       '↑令Brr陣列值寫入Crr陣列指定位置裡[/color]
Next j
If Y(R) > Y("欄數") Then Y("欄數") = Y(R)
[color=SeaGreen] '↑如果上下區的欄號大於以"欄數"查Y字典的item值,
'就令Y字典的"欄數"key對應的item值是上下區的欄號
'Y("欄數")是為了計算陣列最大需求欄數[/color]
Next
With [h2].Resize(UBound(Crr), Y("欄數"))
   .Value = Crr
[color=SeaGreen]    '↑令儲存格值以Crr陣列帶入[/color]
   .Borders.LineStyle = 1
[color=SeaGreen]    '↑令儲存格框線是細實線[/color]
   .ColumnWidth = 4
[color=SeaGreen]    '↑令儲存格欄寬是 4[/color]
   .Font.Size = 14
[color=SeaGreen]    '↑令儲存格字大小是 4[/color]
End With
Set Y = Nothing: Erase Brr, Crr
[color=SeaGreen]'↑令釋放變數[/color]
End Sub

頁: [1]

麻辣家族討論版版's Archiver

資料轉置求助前輩