請問:excel快速合併儲存格

jessicamsu

請問,如何將附件左邊的資料可以快速合併成右手邊的資料,謝謝

chin15

用樞紐分析表

下載 (32.81 KB)

2012-9-7 22:47

jessicamsu

樓上的大大先謝謝,但我因為要貼在另一個sheet並與其他資料彙整,所以樞紐並不適合,謝謝

Hsieh

回復 3# jessicamsu
先用樞紐做出你的格式，再複製貼上就可以

chin15

應該是想練習循環吧？參考

1. Sub test()
   
2.     Dim c%, n%, i%, r%
   
3.     Application.DisplayAlerts = False
   
4.     n = [a65536].End(xlUp).Row
   
5.     For c = 1 To 2
   
6.         r = 2
   
7.         For i = 2 To n
   
8.             If Cells(i, c) <> Cells(i + 1, c) Then
   
9.                 If r < i Then Range(Cells(r, c), Cells(i, c)).Merge
   
10.                 r = i + 1
    
11.             End If
    
12.         Next
    
13.     Next
    
14. End Sub

複製代碼

jessicamsu

謝謝chin15 大大,但經測試後,C欄沒有合併耶,不好意思,再麻煩您幫忙一下

jessicamsu

回復 5# chin15

謝謝chin15 大大,但經測試後,C欄沒有合併耶

將C改為c = 1 To 3, 但C欄黃色部份會有問題,正確應該要像右手邊一樣@@
[attach]12415[/attach]

chin15

c欄不能納入循環中操作

1. Sub test()
   
2.     Dim c%, n%, i%, r%
   
3.     Application.DisplayAlerts = False
   
4.     n = [a65536].End(xlUp).Row
   
5.     For c = 1 To 2
   
6.         r = 2
   
7.         For i = 2 To n
   
8.             If Cells(i, c) <> Cells(i + 1, c) Then
   
9.                 If r < i Then Range(Cells(r, c), Cells(i, c)).Merge
   
10.                 r = i + 1
    
11.             End If
    
12.         Next
    
13.     Next
    
14.     For r = 2 To n
    
15.         If Cells(r, 2).MergeCells Then
    
16.             a = Cells(r, 2).MergeArea.Address
    
17.             s = Split(a, "$")
    
18.             For k = Val(s(2)) To Val(s(4))
    
19.                 Do While Cells(k, 3).Offset(j, 0) = Cells(k, 3) And k + j <= Val(s(4))
    
20.                     j = j + 1
    
21.                 Loop
    
22.                 If j > 1 Then
    
23.                     Cells(k, 3).Resize(j).Merge
    
24.                     k = k + j - 1
    
25.                     j = 1
    
26.                 End If
    
27.             Next
    
28.             r = k - 1
    
29.         End If
    
30.     Next
    
31. End Sub

複製代碼

Hsieh

回復 7# jessicamsu

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Application.DisplayAlerts = False
   
4. For i = 3 To 1 Step -1
   
5.    For Each a In Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
   
6.    mystr = a & a.Offset(, IIf(i = 1, 0, -1))
   
7.       If IsEmpty(d(mystr)) Then
   
8.          Set d(mystr) = a
   
9.          Else
   
10.          Set d(mystr) = Union(d(mystr), a)
    
11.       End If
    
12.     Next
    
13.     For Each ky In d.keys
    
14.     d(ky).Merge
    
15.     Next
    
16.     d.RemoveAll
    
17. Next
    
18. Application.DisplayAlerts = True
    
19. End Sub

複製代碼

c_c_lai

回復 7# jessicamsu
Hsieh 前輩的 Idea 非常棒，我將它稍稍修飾了一下，
即先將 A2:C28 的內容複製到 E2:G28 後再處理分析，
以明確看得出來程式是如何執行處理的。
同時補上了 ky 的變數宣告。

1. Sub ex()
   
2.     Dim ky As Variant
   
3.    
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Application.DisplayAlerts = False
   
6.    
   
7.     [A2:C28].Copy Destination:=[E2]
   
8.    
   
9.     For i = 7 To 5 Step -1
   
10.         For Each a In Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
    
11.             mystr = a & a.Offset(, IIf(i = 5, 0, -1))
    
12.             If IsEmpty(d(mystr)) Then
    
13.                 Set d(mystr) = a
    
14.             Else
    
15.                 Set d(mystr) = Union(d(mystr), a)
    
16.             End If
    
17.         Next
    
18.         For Each ky In d.keys
    
19.             d(ky).Merge
    
20.         Next
    
21.         d.RemoveAll
    
22.     Next
    
23.    
    
24.     Application.DisplayAlerts = True
    
25. End Sub

複製代碼

快速合併儲存格.rar (8.14 KB)

下載次數: 10

2012-9-9 10:36