sayfa silinmesin

[drykcktl]

Ekte hazırlamış olduğum excel dosyamda data sekmesinden sayfalara isimlere göre dağıtıyorum.Ancak belediyelere göre toplam sekmesi içindeki formüllerimi siliyor bunu nasıl sabitleyebilirim acaba

İndir OCAK ANALİZ Kopya

Dosyayı indir OCAK ANALİZ Kopya

dosya.co

 

[Emir Hüseyin Çoban]

Sub SayfaAktar()
Dim i, j As Long, Sayfa As String, S1 As Worksheet
Set S1 = Sheets("DATA")
Application.ScreenUpdating = False

For j = 2 To Worksheets.Count
    If Sheets(j).Name <> "BELEDİYELERE GÖRE TOPLAM" Then
        Sheets(j).Cells.Delete Shift:=xlUp
    End If
Next j

For i = 4 To S1.[D65536].End(3).Row
    Sayfa = Cells(i, "D")
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sayfa
            S1.Select
        End If
    S1.Range("A1:O3").Copy Sheets(Sayfa).Range("A1")
    S1.Range("A" & i & ":O" & i).Copy Sheets(Sayfa).Range("A" & _
    Sheets(Sayfa).[A65536].End(3).Row + 1)
    Sheets(Sayfa).Range("A:O").EntireColumn.AutoFit
Next i
Set S1 = Nothing
Application.ScreenUpdating = True
End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function

 

[drykcktl]

Sub SayfaAktar()
Dim i, j As Long, Sayfa As String, S1 As Worksheet
Set S1 = Sheets("DATA")
Application.ScreenUpdating = False

For j = 2 To Worksheets.Count
    If Sheets(j).Name <> "BELEDİYELERE GÖRE TOPLAM" Then
        Sheets(j).Cells.Delete Shift:=xlUp
    End If
Next j

For i = 4 To S1.[D65536].End(3).Row
    Sayfa = Cells(i, "D")
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sayfa
            S1.Select
        End If
    S1.Range("A1:O3").Copy Sheets(Sayfa).Range("A1")
    S1.Range("A" & i & ":O" & i).Copy Sheets(Sayfa).Range("A" & _
    Sheets(Sayfa).[A65536].End(3).Row + 1)
    Sheets(Sayfa).Range("A:O").EntireColumn.AutoFit
Next i
Set S1 = Nothing
Application.ScreenUpdating = True
End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function

tesekkür ederim