帖子: 38
主題: 7
精華: 0
積分: 48
點名: 0
作業系統: win8
軟體版本: office2010
閱讀權限: 10
性別: 男
註冊時間: 2015-4-30
最後登錄: 2016-12-5

1^# 跳轉到 » 正序看帖

字體大小: tT

發表於 2015-6-22 16:21 | 只看該作者

[發問] 資料轉置的小問題

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

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

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

但我只想要如圖示的,轉置後資料變成兩欄中就好
懇請大大們指點一二

樓主熱帖

lpk187

高中生 Rank: 3 Rank: 3

帖子: 552
主題: 3
精華: 0
積分: 578
點名: 0
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2015-2-8
最後登錄: 2024-2-26

2016猴年全勤獎章 2015羊年全勤獎章熱烈參與勳章

13^#

發表於 2015-7-3 20:40 | 只看該作者

回復 12# GBKEE

感謝G大解惑！謝謝！

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

12^#

發表於 2015-7-3 20:08 | 只看該作者

回復 11# boblovejoyce

Option Explicit
Sub Ex()
Dim Rng As Range, Ar1(), x As Integer, Ar2(), i As Integer
Dim Y As Integer, S As String
Set Rng = [F1]
Do While Rng <> ""
i = 0: Y = 1: S = ""
While Mid(Rng, Y, 1) Like "[A-z]" '是字母
S = Mid(Rng, 1, Y)
Y = Y + 1
Wend
If S <> "" And S = Mid(Rng.Offset(i), 1, Y - 1) Then
ReDim Preserve Ar1(x + 1)
ReDim Ar2(i)
Ar2(i) = S
Do While S = Mid(Rng.Offset(i), 1, Y - 1)
i = i + 1
ReDim Preserve Ar2(i)
Ar2(i) = Rng.Offset(i - 1, 1)
Loop
Ar1(x + 1) = Ar2
Set Rng = Rng.Offset(i)
x = x + 1
End If
Loop
ReDim Ar2(i)
For i = 0 To i
Ar2(i) = IIf(i > 0, i, "")
Next
Ar1(0) = Ar2
' For i = 1 To UBound(Ar1)
' [I1].Offset(i).Resize(, UBound(Ar1(i)) + 1) = Ar1(i) '一行一行的寫入
' Next
'*********** 一次寫入
[I1].Resize(UBound(Ar1) + 1, UBound(Ar2) + 1).Value = Application.Transpose(Application.Transpose(Ar1))
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

boblovejoyce

小學生 Rank: 1

帖子: 38
主題: 7
精華: 0
積分: 48
點名: 0
作業系統: win8
軟體版本: office2010
閱讀權限: 10
性別: 男
註冊時間: 2015-4-30
最後登錄: 2016-12-5

11^#

發表於 2015-7-3 19:19 | 只看該作者

回復 9# GBKEE

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

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

test0703.rar (22.26 KB)

TOP

lpk187

高中生 Rank: 3 Rank: 3

帖子: 552
主題: 3
精華: 0
積分: 578
點名: 0
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2015-2-8
最後登錄: 2024-2-26

2016猴年全勤獎章 2015羊年全勤獎章熱烈參與勳章

10^#

發表於 2015-7-3 11:10 | 只看該作者

回復 9# GBKEE

請教G大，假設，我在F欄的名稱中有A1,A2,AA1,AA2, AAA1,AAA2時，要怎麼修改？

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

9^#

發表於 2015-7-3 10:24 | 只看該作者

回復 8# boblovejoyce
試試看

Option Explicit
Sub Ex()
Dim Rng As Range, Ar1(), x As Integer, Ar2(), i As Integer
Set Rng = [F1]
Do While Rng <> ""
i = 0
If Mid(Rng, 1, 1) = Mid(Rng.Offset(i), 1, 1) Then
ReDim Preserve Ar1(x + 1)
ReDim Ar2(i)
Ar2(i) = Mid(Rng, 1, 1)
Do While Mid(Rng, 1, 1) = Mid(Rng.Offset(i), 1, 1)
i = i + 1
ReDim Preserve Ar2(i)
Ar2(i) = Rng.Offset(i - 1, 1)
Loop
Ar1(x + 1) = Ar2
Set Rng = Rng.Offset(i)
x = x + 1
End If
Loop
ReDim Ar2(i)
For i = 0 To i
Ar2(i) = IIf(i > 0, i, "")
Next
Ar1(0) = Ar2
For i = 0 To UBound(Ar1)
[I1].Offset(i).Resize(, UBound(Ar1) + 1) = Ar1(i) '一行一行的寫入
Next
'*********** 一次寫入
[I1].Resize(UBound(Ar1) + 1, UBound(Ar2) + 1).Value = Application.Transpose(Application.Transpose(Ar1))
End Sub