資料轉置的小問題 - Excel程式區 - 麻辣家族討論版版

麻辣家族討論版版 » Excel程式區 » 資料轉置的小問題

返回列表下一主題上一主題發帖

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

超級版主 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兔年全勤獎章

4^# 跳轉到 »

發表於 2015-6-23 16:10 | 只看該作者

回復 2# lpk187
一次的迴圈

Option Explicit
Sub Ex()
Dim Ar(), i As Integer
With Range([B2], Range("b2").End(xlToRight).End(xlDown))
ReDim Ar(1 To .Count, 1 To 2)
For i = 1 To .Count
Ar(i, 1) = .Cells(i).End(xlToLeft) & .Cells(i).End(xlUp)
Ar(i, 2) = .Cells(i)
Next
.Cells(.Rows.Count + 2, 1).Resize(.Count, 2) = Ar
End With
End Sub

複製代碼

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

小學生 Rank: 1

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

3^#

發表於 2015-6-22 23:34 | 只看該作者

回復 2# lpk187

:loveliness:
可以使用~~神來一解~~
每次都是大大解惑之
太感謝了~:)
學習中~

高中生 Rank: 3 Rank: 3

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

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

2^#

發表於 2015-6-22 18:34 | 只看該作者

回復 1# boblovejoyce

試試看吧！

Sub test()
Dim arr1()
en = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("b2:c" & en)
x = 1
j = 1
For Each Rng In Range("a2:a" & en)
i = 1
For Each rng1 In [b1:c1]
ReDim Preserve arr1(1 To 2, 1 To x)
arr1(1, x) = Rng & rng1
arr1(2, x) = arr(j, i)
x = x + 1: i = i + 1
Next
j = j + 1
Next
[F1].Resize(UBound(arr1, 2), 2) = Application.Transpose(arr1)
End Sub

複製代碼

靜思自在 : 稻穗結得越飽滿，越會往下垂，一個人越有成就，就要越有謙沖的胸襟。

返回列表下一主題上一主題