Board logo

標題: [發問] 資料轉置的小問題 [打印本頁]
作者: boblovejoyce    時間: 2015-6-22 16:21     標題: 資料轉置的小問題

[attach]21231[/attach]

這個轉置的方式,我爬文爬爬找不到類似的方式
可是又覺得應該是很簡單~類似文章應該有類似的

在某個文章有看到下面的代碼:
Sub test()
    Dim arr
    arr = Range("a1:c3")
    Range("f1").Resize(UBound(arr, 2), UBound(arr)) = Application.WorksheetFunction.Transpose(arr)
End Sub

很簡單的就轉置了~
可是他是整個資料範圍轉置

但我只想要如圖示的,轉置後資料變成兩欄中就好
懇請大大們 指點一二
作者: lpk187    時間: 2015-6-22 18:34

回復 1# boblovejoyce

試試看吧！
  1. Sub test()
  2. Dim arr1()
  3. en = Cells(Rows.Count, 1).End(xlUp).Row
  4. arr = Range("b2:c" & en)
  5. x = 1
  6. j = 1
  7. For Each Rng In Range("a2:a" & en)
  8.     i = 1
  9.     For Each rng1 In [b1:c1]
  10.         ReDim Preserve arr1(1 To 2, 1 To x)
  11.         arr1(1, x) = Rng & rng1
  12.         arr1(2, x) = arr(j, i)
  13.         x = x + 1: i = i + 1
  14.     Next
  15.     j = j + 1
  16. Next
  17. [F1].Resize(UBound(arr1, 2), 2) = Application.Transpose(arr1)
  18. End Sub
複製代碼
作者: boblovejoyce    時間: 2015-6-22 23:34

回復 2# lpk187


    :loveliness:
可以使用~~神來一解~~
每次都是大大解惑之
太感謝了~:)
學習中~
作者: GBKEE    時間: 2015-6-23 16:10

回復 2# lpk187
一次的迴圈
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Ar(), i As Integer
  4.     With Range([B2], Range("b2").End(xlToRight).End(xlDown))
  5.         ReDim Ar(1 To .Count, 1 To 2)
  6.         For i = 1 To .Count
  7.             Ar(i, 1) = .Cells(i).End(xlToLeft) & .Cells(i).End(xlUp)
  8.             Ar(i, 2) = .Cells(i)
  9.         Next
  10.         .Cells(.Rows.Count + 2, 1).Resize(.Count, 2) = Ar
  11.     End With
  12. End Sub
複製代碼
作者: lpk187    時間: 2015-6-23 17:52

本帖最後由 lpk187 於 2015-6-23 17:53 編輯

回復 5# GBKEE


   Try過版大的程式碼後，版大你太強大了，之前沒什麼學到with...
經過這程式真讓我學到蠻厚實的經驗，原來With 這麼好用，GBKEE版大，感謝！
作者: boblovejoyce    時間: 2015-7-1 22:25

回復 4# GBKEE

wow~謝謝版大提供這種方式~
那有無可以反轉回去呢?

就像是此例,可以轉乘兩資料欄
如果只有兩資料欄~可以轉回去陣列的樣式嗎?
作者: c_c_lai    時間: 2015-7-2 07:03

回復  GBKEE

wow~謝謝版大提供這種方式~
那有無可以反轉回去呢?

就像是此例,可以轉乘兩資料欄
如果 ...
boblovejoyce 發表於 2015-7-1 22:25


你指的是？
  1.         .Cells(.Rows.Count + 2, 1).Resize(.Count, 2) = Ar
  2.        [F1].Resize(UBound(Ar, 2), 4) = Application.Transpose(Ar)
複製代碼
作者: boblovejoyce    時間: 2015-7-3 08:40

回復 4# GBKEE

板主大大~
其實是想詢問,如下圖
左圖:經過大大的程式碼,已經可以轉置了

但如果反過來,給的是右圖
怎麼將F G 欄位 ,轉成 I J K呢?

  [attach]21306[/attach]
作者: GBKEE    時間: 2015-7-3 10:24

回復 8# boblovejoyce
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng As Range, Ar1(), x As Integer, Ar2(), i As Integer
  4.     Set Rng = [F1]
  5.     Do While Rng <> ""
  6.         i = 0
  7.         If Mid(Rng, 1, 1) = Mid(Rng.Offset(i), 1, 1) Then
  8.             ReDim Preserve Ar1(x + 1)
  9.             ReDim Ar2(i)
  10.             Ar2(i) = Mid(Rng, 1, 1)
  11.             Do While Mid(Rng, 1, 1) = Mid(Rng.Offset(i), 1, 1)
  12.                 i = i + 1
  13.                 ReDim Preserve Ar2(i)
  14.                 Ar2(i) = Rng.Offset(i - 1, 1)
  15.             Loop
  16.             Ar1(x + 1) = Ar2
  17.             Set Rng = Rng.Offset(i)
  18.             x = x + 1
  19.         End If
  20.     Loop
  21.     ReDim Ar2(i)
  22.     For i = 0 To i
  23.         Ar2(i) = IIf(i > 0, i, "")
  24.     Next
  25.     Ar1(0) = Ar2
  26.     For i = 0 To UBound(Ar1)
  27.         [I1].Offset(i).Resize(, UBound(Ar1) + 1) = Ar1(i) '一行一行的寫入
  28.     Next
  29.     '*********** 一次寫入
  30.     [I1].Resize(UBound(Ar1) + 1, UBound(Ar2) + 1).Value = Application.Transpose(Application.Transpose(Ar1))
  31. End Sub
複製代碼
作者: lpk187    時間: 2015-7-3 11:10

回復 9# GBKEE


    請教G大，假設，我在F欄的名稱中有A1,A2,AA1,AA2, AAA1,AAA2時，要怎麼修改？
作者: boblovejoyce    時間: 2015-7-3 19:19

回復 9# GBKEE

謝謝G大
不過真如樓上所說的,若有AA1,AM1這樣的字眼的時候
就會出現型態不符合

我快速抓了一份資訊,如附件,轉換的時候
會出現型態不符合

    [attach]21317[/attach]
作者: GBKEE    時間: 2015-7-3 20:08

回復 11# boblovejoyce
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng As Range, Ar1(), x As Integer, Ar2(), i As Integer
  4.     Dim Y As Integer, S As String
  5.     Set Rng = [F1]
  6.     Do While Rng <> ""
  7.         i = 0: Y = 1: S = ""
  8.         While Mid(Rng, Y, 1) Like "[A-z]"  '是字母
  9.             S = Mid(Rng, 1, Y)
  10.             Y = Y + 1
  11.         Wend
  12.         If S <> "" And S = Mid(Rng.Offset(i), 1, Y - 1) Then
  13.             ReDim Preserve Ar1(x + 1)
  14.             ReDim Ar2(i)
  15.             Ar2(i) = S
  16.             Do While S = Mid(Rng.Offset(i), 1, Y - 1)
  17.                 i = i + 1
  18.                 ReDim Preserve Ar2(i)
  19.                 Ar2(i) = Rng.Offset(i - 1, 1)
  20.             Loop
  21.             Ar1(x + 1) = Ar2
  22.             Set Rng = Rng.Offset(i)
  23.             x = x + 1
  24.         End If
  25.     Loop
  26.     ReDim Ar2(i)
  27.     For i = 0 To i
  28.         Ar2(i) = IIf(i > 0, i, "")
  29.     Next
  30.     Ar1(0) = Ar2
  31.    ' For i = 1 To UBound(Ar1)
  32.    '     [I1].Offset(i).Resize(, UBound(Ar1(i)) + 1) = Ar1(i) '一行一行的寫入
  33.    ' Next
  34.    '*********** 一次寫入
  35.     [I1].Resize(UBound(Ar1) + 1, UBound(Ar2) + 1).Value = Application.Transpose(Application.Transpose(Ar1))
  36. End Sub
複製代碼
作者: lpk187    時間: 2015-7-3 20:40

回復 12# GBKEE


    感謝G大解惑！謝謝！



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)