資料轉置求助前輩
資料轉置求助前輩,如何直式轉橫式分上下半年,懇請先進幫忙,感恩. [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115280&ptid=23162]1#[/url] [i]dou10801[/i] [/b] [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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115281&ptid=23162]2#[/url] [i]singo1232001[/i] [/b]
大大您好,如果資料來源在多加幾列,結果顯示會不一樣,請再測試看看,謝謝。 有出狀況的範例嗎 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115284&ptid=23162]5#[/url] [i]singo1232001[/i] [/b]
如附件請您測試看看,謝謝。 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]
================================ [url]https://blog.xuite.net/hcm19522/twblog/589826553[/url] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115285&ptid=23162]6#[/url] [i]samwang[/i] [/b] [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 感謝各方前輩指點,收下慢慢學習. [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 謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
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]