Birleştirilmiş sütunları çözme

[flz82]

Örnekteki A1 sütunu gibi birleştirilmiş 3000 satırlık bir excel dosyası var. B sütunundaki gibi sütunun çözülüp satırlara ayrılmasını istiyorum. Yardımcı olursanız sevinirim.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp dener misiniz?

Sub Ornek()
    
    Dim i   As Long
    
    Range("B:B").ClearContents
    i = 1
    
    Do
        Range("B" & i & ":B" & i + Range("A" & i).MergeArea.Count - 1) = Range("A" & i)
        
        i = Cells(i, "A").End(4).Row
    Loop Until Cells(i, "A") = ""
    
End Sub

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
Application.ScreenUpdating = False

Range("A" & [A65536].End(3).Row).Select
With Selection
    ilk_sat = .Row
    son_sat = .Rows.Count + ilk_sat - 1
End With

Range("A1:A" & son_sat).Select
Selection.UnMerge

For i = 1 To son_sat
If Cells(i, "A") = "" Then
Cells(i, "A") = Cells(i - 1, "A")
Else

End If
Next i
Range("A1").Select

Application.ScreenUpdating = True
MsgBox " B i t t i "
End Sub

. . .

 

[Necdet]

hmmmm A sütununda olacakmış.

Sub Ornek()
    
    Dim i   As Long
 
    i = Cells(Rows.Count, "A").End(3).Row
    i = i + Range("A" & i).MergeArea.Count - 1
    
    Range("A:A").UnMerge
    Range("A1:A" & i).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    With Range("A1:A" & i)
        .Copy
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End With
    Application.CutCopyMode = False
    Range("A1").Activate
    
End Sub

 

[flz82]

Her ikisi de istediğim sonucu verdi, teşekkür ederim elinize sağlık..