Board logo

標題: 《請教》vba 合併儲存格 [打印本頁]
作者: eric093    時間: 2013-12-16 16:58     標題: 《請教》vba 合併儲存格

請教各位大師們有關vba的合併儲存格，如相同資料則合併，如下方，我執行不對，請大家指點一下


地區
新竹
新竹
桃園
桃園
桃園
桃園
台北
台北
台北
台北
Sub bb()
Dim xRng, xRng1 As Range
Application.DisplayAlerts = False

k = Range("a65536").End(xlUp).Row

For j =2 to k  
Set xRng = Cells(j, 1)
Set xRng1 = Cells(j - 1, 1)
If xRng1 = xRng Then
     
   Range(xRng, xRng1).Merge
   
End If

Next



End Sub
作者: GBKEE    時間: 2013-12-16 17:58

回復 1# eric093

試試看
  1. Sub bb()
  2.     Dim xRng(1 To 2) As Range, J As Integer
  3.     Application.DisplayAlerts = False
  4.     Set xRng(1) = Range("A2")
  5.     J = 1
  6.     Do While xRng(1) <> ""
  7.         If xRng(1).Offset(J) = xRng(1) Then
  8.             Set xRng(2) = Union(IIf(xRng(2) Is Nothing, xRng(1), xRng(2)), xRng(1).Offset(J))
  9.             J = J + 1
  10.         Else
  11.             Set xRng(1) = xRng(1).Offset(J)
  12.             J = 1
  13.             xRng(2).Merge
  14.             Set xRng(2) = Nothing
  15.         End If
  16.     Loop
  17. End Sub
複製代碼
作者: eric093    時間: 2013-12-16 20:17

回復 2# GBKEE


    感謝囉！
　是我想的太簡單囉。
作者: rouber590324    時間: 2018-5-30 16:48

dear all 大大
1.執行後儲存格A2-A15友執行相同內容合併.然後停於 xRng(2).Merge 秀出 沒有設定物件變數或with塊變數
2.why?? 煩不吝賜教. thanks   

Sub bb()

    Dim xRng(1 To 2) As Range, J As Integer

    Application.DisplayAlerts = False

    Set xRng(1) = Range("A2")

    J = 1

    Do While xRng(1) <> ""

        If xRng(1).Offset(J) = xRng(1) Then

            Set xRng(2) = Union(IIf(xRng(2) Is Nothing, xRng(1), xRng(2)), xRng(1).Offset(J))

            J = J + 1

        Else

            Set xRng(1) = xRng(1).Offset(J)

            J = 1

            xRng(2).Merge

            Set xRng(2) = Nothing

        End If

    Loop

End Sub
作者: Kubi    時間: 2018-5-30 22:29

回復 1# eric093
  1. Sub bb()
  2.     k = Range("A65536").End(xlUp).Row
  3.     Application.DisplayAlerts = False
  4.     For j = 1 To k
  5.         If Cells(j, 1).Value <> A Then
  6.             A = Cells(j, 1).Value
  7.             d = Cells(j, 1).Address
  8.         Else
  9.             Range(d & ":" & Cells(j, 1).Address).Merge
  10.         End If
  11.     Next
  12.     Application.DisplayAlerts = True
  13. End Sub
複製代碼
作者: rouber590324    時間: 2018-5-31 08:46

DEAR Kubi 大大
感謝您之解惑  THANKS*10000
作者: 准提部林    時間: 2018-6-3 18:00

Sub TEST()
Dim xR As Range, xH As Range
Application.DisplayAlerts = False
For Each xR In Range([A2], [A65536].End(xlUp))
    If xR <> xR(0) Then Set xH = xR
    If xR <> xR(2) Then Range(xR, xH).Merge
Next
End Sub
作者: rouber590324    時間: 2018-6-5 11:49

DEAR  准提部林 大大
1.100%符合需求 感謝您之解惑  THANKS*10000



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)