不規則資料，如何重整..... - Excel程式區 - 麻辣家族討論版版

麻辣家族討論版版 » Excel程式區 » 不規則資料，如何重整.....

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

[發問] 不規則資料，如何重整.....

小學生 Rank: 1

帖子: 14
主題: 5
精華: 0
積分: 19
點名: 0
作業系統: xp
軟體版本: 2003
閱讀權限: 10
性別: 男
註冊時間: 2011-9-5
最後登錄: 2015-7-22

5^# 跳轉到 »

發表於 2015-7-22 18:04 | 只看該作者

回復 4# 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兔年全勤獎章

4^#

發表於 2015-7-22 14:01 | 只看該作者

回復 3# b31978
試試看

'一般模組程式碼
Option Explicit
Sub Ex()
Dim Rng As Range, C As Range, S, Ar(), At(), i As Integer
Set Rng = ActiveSheet.Range("A3")
Do While Rng <> ""
With Rng.Offset(, 2).Resize(Rng.MergeArea.Count, 7)
'Rng.MergeArea 儲存格的合併範圍
'Rng.MergeArea.Count 合併範圍的Cells總計
If Application.CountA(.Cells) > 0 Then '.Cells :這 With 物件範圍Range的Cells
'工作表函數 CountA 計算範圍內有資料的Cells個數
For Each C In .SpecialCells(xlCellTypeConstants)
'SpecialCells 特殊儲存格 (xlCellTypeConstants :字串,數字 )
ReDim Ar(1 To 4) '重置陣列
Ar(1) = Rng.Value
Ar(2) = Cells(2, C.Column)
Ar(3) = C
Ar(4) = Cells(C.Row, "j")
i = i + 1
ReDim Preserve At(1 To i) '重置陣列:Preserve保留原有的元素
At(i) = Ar
Next
End If
End With
Set Rng = Rng.End(xlDown) '下一個有合併範圍的Range
Loop
If i > 0 Then [M3].Resize(i, 4) = Application.Transpose(Application.Transpose(At))
End Sub

複製代碼

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

小學生 Rank: 1

帖子: 14
主題: 5
精華: 0
積分: 19
點名: 0
作業系統: xp
軟體版本: 2003
閱讀權限: 10
性別: 男
註冊時間: 2011-9-5
最後登錄: 2015-7-22

3^#

發表於 2015-7-22 07:54 | 只看該作者

回復 2# lpk187

感謝，想了很久，一直沒有有效的思路，謝謝大大~ 感恩:D

高中生 Rank: 3 Rank: 3

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

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

2^#

發表於 2015-7-21 17:43 | 只看該作者

回復 1# b31978

試試看，也不知對不對！

Public Sub test()
Dim arr()
aa = Cells(Rows.Count, 10).End(xlUp).Row
xx = WorksheetFunction.CountA(Range("J3:J" & aa))
i = 1
ReDim arr(1 To xx, 1 To 4)
For Each Rng In Range("C3:i" & aa)
If Rng <> "" Then
ss = Cells(Rng.Row, 1).MergeArea
arr(i, 1) = ss(1, 1)
arr(i, 2) = Cells(2, Rng.Column)
arr(i, 3) = Rng
arr(i, 4) = Cells(Rng.Row, 10)
i = i + 1
End If
Next
Range("M3").Resize(xx, 4) = arr
End Sub

複製代碼

靜思自在 : 對父母要知恩，感恩、報恩。

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