《請教》vba 合併儲存格

eric093

請教各位大師們有關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

回復 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

回復 2# GBKEE


    感謝囉！
　是我想的太簡單囉。

rouber590324

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

回復 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

DEAR Kubi 大大
感謝您之解惑  THANKS*10000

准提部林

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

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