請問如何用VBA.自動合併儲存格&quot;跨列置中&quot;

帖子: 18
主題: 7
精華: 0
積分: 26
點名: 0
作業系統: win xp
軟體版本: office2003
閱讀權限: 10
性別: 女
註冊時間: 2013-6-17
最後登錄: 2020-6-20

10^#

發表於 2013-7-8 11:39 | 只看該作者

GBKEE 大大
你幫忙修改的程式碼出現2各狀況
1.所選取的範圍第一各合併的儲存格的第一列都無法合併.如:1.2列要合併(無作用)如:1.2.3列要合併(2.3列會合併.但不會跟1列合併)如:1.2.3.4列要合併(2.3.4會合併.但1列還是無法一起合併)
是每次要選取合併範圍第一各合併都會有這種現象
2.如果是點選整欄就會最後一各合併儲存格無限大的往下延伸

PS原來kimbal 大大提供的程式碼產生的那各問題.在你修正的程式碼裡已解決

真不好意思一直找麻煩:(

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^#

發表於 2013-7-7 15:03 | 只看該作者

回復 7# joey3277
修改如下

Option Explicit
Sub test()
Dim lngRowCount As Long, Rng As Range, R As Range
Dim lngRowCounter As Long
Dim lngRowCountLast As Long
On Error Resume Next '不理會程序上的錯誤,繼續執行程式
Set Rng = Application.InputBox("選取儲存格(可選多重範圍)", Type:=8) '如沒有選取儲存格:程序上的錯誤
If Err <> 0 Then Exit Sub '程序上有錯誤
For Each R In Rng.Areas
lngRowCount = R.Rows.Count '範圍的總列數
lngRowCountLast = 1
For lngRowCounter = 2 To lngRowCount
With R.Range("A1")
If .Offset(lngRowCounter) <> "" Or lngRowCounter = lngRowCount Then
If Not (lngRowCountLast = lngRowCounter - 1) Then
.Parent.Range(.Offset(lngRowCountLast), .Offset(lngRowCounter - 1)).Merge
End If
lngRowCountLast = lngRowCounter
End If
End With
Next
Next
End Sub

複製代碼

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

帖子: 18
主題: 7
精華: 0
積分: 26
點名: 0
作業系統: win xp
軟體版本: office2003
閱讀權限: 10
性別: 女
註冊時間: 2013-6-17
最後登錄: 2020-6-20

8^#

發表於 2013-7-7 13:04 | 只看該作者

謝謝GBKEE 大大提供的程式碼
測試過了超級方便好用

謝謝幫忙

帖子: 18
主題: 7
精華: 0
積分: 26
點名: 0
作業系統: win xp
軟體版本: office2003
閱讀權限: 10
性別: 女
註冊時間: 2013-6-17
最後登錄: 2020-6-20

7^#

發表於 2013-7-7 13:01 | 只看該作者

請教一下kimbal 大大
使用你提供的程式碼遇到了一各問題
如果最後一個要合併的儲存格要合併的格數是兩格的話
程式碼就會抓不到最後一各
如提供的表上最後一格要合併的是15.16.17列這沒有問題
但如果只要合併15.16列程式就只會執行到13列

PS.可另請教如果要合併的只有B欄
那你提供的程式碼要改哪邊呢?

帖子: 18
主題: 7
精華: 0
積分: 26
點名: 0
作業系統: win xp
軟體版本: office2003
閱讀權限: 10
性別: 女
註冊時間: 2013-6-17
最後登錄: 2020-6-20

6^#

發表於 2013-7-6 12:39 | 只看該作者

謝謝大大的幫忙！！趕緊試試

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兔年全勤獎章

5^#

發表於 2013-7-5 09:11 | 只看該作者

回復 4# joey3277
試試看

Option Explicit
Sub Ex()
Dim Rng(1 To 3) As Range, A As Range, C As Range, R As Integer
On Error Resume Next '不理會程序上的錯誤,繼續執行程式
Set Rng(1) = Application.InputBox("選取儲存格(可選多重範圍)", Type:=8) '如沒有選取儲存格:程序上的錯誤
If Err <> 0 Then Exit Sub '程序上有錯誤
On Error GoTo 0 '不處裡程序上的錯誤
For Each A In Rng(1).Areas '物件集合: Areas (多重範圍)
For Each C In A.Columns '物件集合: Columns(欗位)
Set Rng(2) = C.Cells(1) '物件:範圍的,第1個,儲存格開始
R = C.Cells(C.Cells.Count).Row '數值 :物件範圍最後的儲存格列號
Do
Set Rng(3) = Rng(2).Offset(1) '物件 Rng(3): Rng(2)的下一列儲存格
Do While Rng(3) = "" And Rng(3).Row <= R 'While(條件成立,執行迴圈):(物件="" 且須物件<>物件範圍的最後列號)
Set Rng(3) = Rng(3).Offset(1) '物件 Rng(3): Rng(3)的下一列儲存格
Loop
Rng(1).Parent.Range(Rng(2), Rng(3).Offset(-1)).Merge 'Merge(合併儲存格)
Set Rng(2) = Rng(3) '物件 Rng(2): 有資料數值的儲存格
Loop Until Rng(3).Row > R 'Until(條件不成立,執行迴圈)
Next
Next
End Sub

複製代碼

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

帖子: 18
主題: 7
精華: 0
積分: 26
點名: 0
作業系統: win xp
軟體版本: office2003
閱讀權限: 10
性別: 女
註冊時間: 2013-6-17
最後登錄: 2020-6-20

4^#

發表於 2013-7-4 19:25 | 只看該作者

再請問一下
1.可否修改程式為"選取的儲存格範圍".或著選取的欄別
2.或著合併儲存格只有固定一欄時

應該修改哪各地方

謝謝

帖子: 18
主題: 7
精華: 0
積分: 26
點名: 0
作業系統: win xp
軟體版本: office2003
閱讀權限: 10
性別: 女
註冊時間: 2013-6-17
最後登錄: 2020-6-20

3^#

發表於 2013-6-26 22:05 | 只看該作者

謝謝大大熱心的提供VBA

版主 Rank: 7 Rank: 7 Rank: 7

kimbal

帖子: 472
主題: 5
精華: 0
積分: 485
點名: 0
作業系統: Windows
軟體版本: MS Office
閱讀權限: 100
性別: 男
來自: 香港
註冊時間: 2010-7-4
最後登錄: 2014-12-28

論壇貢獻勳章

2^#

發表於 2013-6-25 22:34 | 只看該作者

Sub test()
Dim lngRowCount As Long
Dim lngRowCounter As Long
Dim lngRowCountLast As Long
lngRowCount = Range("C1").End(xlDown).Row
If lngRowCount = 2 Then Exit Sub
lngRowCountLast = 1
For lngRowCounter = 2 To lngRowCount - 1
With Range("A1")
If lngRowCounter = lngRowCount - 1 And Not (lngRowCountLast = lngRowCounter - 1) Then
Range(.Offset(lngRowCountLast), .Offset(lngRowCounter)).Merge
Range(.Offset(lngRowCountLast, 1), .Offset(lngRowCounter, 1)).Merge
End If
If .Offset(lngRowCounter) <> "" Then
If Not (lngRowCountLast = lngRowCounter - 1) Then
Range(.Offset(lngRowCountLast), .Offset(lngRowCounter - 1)).Merge
Range(.Offset(lngRowCountLast, 1), .Offset(lngRowCounter - 1, 1)).Merge
End If
lngRowCountLast = lngRowCounter
End If
End With
Next
End Sub

複製代碼

懂得發問,答案就會在其中

今日の一秒は明日にない
http://kimbalko-chi.blogspot.com
http://kimbalko.blogspot.com