Birleştirilmiş hücreler ile sayfa aktar

[qwertylion]

merhaba arkadaşlar;

Forumda bir çok sayfalara dağıt, aktar kodları mevcut fakat hücrelerden bazıları için hücre birleştirme uygulanmış ise kodlar hata veriyor.

ekteki dosyadanda anlaşılacağı üzere birleştirilmiş hücrelerle beraber sayfalara aktarmak istiyorum. (ANKARA VE İSTANBUL ŞEKLİNDE)

Teşekkür ederim.

 

[hamitcan]

Bu şekilde dener misiniz ?

Sub Aktar()
    SayfalariTemizle
    With Sheets("ANA VERİ")
    s = .[a65536].End(3).Row
    For i = 5 To s
        If SayfaVarmi(.Cells(i, 1)) = "Hayır" Then Sheets.Add: ActiveSheet.Name = .Cells(i, 1)
        x = Sheets(CStr(.Cells(i, 1))).[a65536].End(3).Row + 1
        Sheets(CStr(.Cells(i, 1))).Cells(x, 1) = .Cells(i, 1)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 2) = BirlesmisHucreDegeri(.Cells(i, 1).Address)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 3) = BirlesmisHucreDegeri(.Cells(i, 2).Address)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 4) = BirlesmisHucreDegeri(.Cells(i, 3).Address)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 5) = BirlesmisHucreDegeri(.Cells(i, 4).Address)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 6) = BirlesmisHucreDegeri(.Cells(i, 5).Address)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 7) = BirlesmisHucreDegeri(.Cells(i, 6).Address)
    Next
    End With
End Sub
Sub SayfalariTemizle()
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> "ANA VERİ" Then Sheets(i).Cells.ClearContents
    Next
End Sub
Function SayfaVarmi(SayfaAdi As String)
    For i = 1 To Sheets.Count
        If Sheets(i).Name = SayfaAdi Then s = s + 1
    Next
    If s > 0 Then SayfaVarmi = "Evet" Else SayfaVarmi = "Hayır"
End Function
Function BirlesmisHucreDegeri(HucreAdresi As String)
    If Range(HucreAdresi).Offset(0, 1).MergeCells Then
        BirlesmisHucreDegeri = Range(HucreAdresi).Offset(0, 1).MergeArea.Cells(1).Value
    Else
        BirlesmisHucreDegeri = Range(HucreAdresi).Offset(0, 1)
    End If
End Function

 

[qwertylion]

İlgi ve alakanız için teşekkür ederim,

Başlık dışında tam istediğim gibi olmuş, rica etsem başlıkta gelebilirmi acaba?

 

[hamitcan]

İlgili kodu aşağıdaki ile değiştirin.

Sub Aktar()
    SayfalariTemizle
    With Sheets("ANA VERİ")
    s = .[a65536].End(3).Row
    For i = 5 To s
        If SayfaVarmi(.Cells(i, 1)) = "Hayır" Then Sheets.Add: ActiveSheet.Name = .Cells(i, 1)
       [color=red] .[a3:f4].Copy Sheets(CStr(.Cells(i, 1))).[a3:f4][/color]
        x = Sheets(CStr(.Cells(i, 1))).[a65536].End(3).Row + 1
        Sheets(CStr(.Cells(i, 1))).Cells(x, 1) = .Cells(i, 1)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 2) = BirlesmisHucreDegeri(.Cells(i, 1).Address)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 3) = BirlesmisHucreDegeri(.Cells(i, 2).Address)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 4) = BirlesmisHucreDegeri(.Cells(i, 3).Address)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 5) = BirlesmisHucreDegeri(.Cells(i, 4).Address)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 6) = BirlesmisHucreDegeri(.Cells(i, 5).Address)
        Sheets(CStr(.Cells(i, 1))).Cells(x, 7) = BirlesmisHucreDegeri(.Cells(i, 6).Address)
    Next
    End With
End Sub

 

[qwertylion]

Teşekkür ederim