[發問] 資料轉置求助前輩

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

3^#

發表於 2021-6-10 16:34 | 只看該作者

回復 1# dou10801

請測試看看，謝謝。

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

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

4^#

發表於 2021-6-10 17:31 | 只看該作者

回復 2# singo1232001

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

singo1232001

　暱稱: 熱狗慶

中學生 Rank: 2

帖子: 354
主題: 5
精華: 0
積分: 387
點名: 0
作業系統: windows7
軟體版本: vba,vb,excel2007
閱讀權限: 20
性別: 男
註冊時間: 2017-1-8
最後登錄: 2024-8-2

論壇榮譽勳章論壇贊助勳章

5^#

發表於 2021-6-10 23:59 | 只看該作者

有出狀況的範例嗎

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

6^#

發表於 2021-6-11 06:09 | 只看該作者

回復 5# singo1232001

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

排班表如何套入表格2_v1.zip (23.77 KB)

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2848
主題: 10
精華: 0
積分: 2903
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2026-7-25

7^#

發表於 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

Xl0000541.rar (13.97 KB)

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

https://blog.xuite.net/hcm19522/twblog/589826553

hcm19522

碩士班 Rank: 5 Rank: 5

帖子: 1798
主題: 185
精華: 0
積分: 1988
點名: 0
作業系統: WIN
軟體版本: 2007
閱讀權限: 100
性別: 男
註冊時間: 2015-9-11
最後登錄: 2026-9-28

熱烈參與勳章

8^#

發表於 2021-6-11 10:01 | 只看該作者

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

singo1232001

　暱稱: 熱狗慶

中學生 Rank: 2

帖子: 354
主題: 5
精華: 0
積分: 387
點名: 0
作業系統: windows7
軟體版本: vba,vb,excel2007
閱讀權限: 20
性別: 男
註冊時間: 2017-1-8
最後登錄: 2024-8-2

論壇榮譽勳章論壇贊助勳章

9^#

發表於 2021-6-11 14:29 | 只看該作者

回復 6# samwang

排班表如何套入表格2_v2.zip (25.31 KB)

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

10^#

發表於 2021-6-11 16:16 | 只看該作者

回復 9# singo1232001

# 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("h2").Resize((x + 1) * 4, 16) = Brr
End Sub