Girilen hücre içerigine göre yeni sayfa açıp satırı kopyalama

[Antepliislam]

Merhabalar, bu örnege baktım fakat içinden çıkamadım, benim sizden istegim ise D Sütunundaki Banka adına göre Sayfa 1 deki girilen banka adına göre banka sayfası açıp oraya sadece o bankanın oldugu satırlarının tümünün kopyalanmasını istiyorum. Yani her bankanın kredileri ayrı ayrı otomatik olarak oluşturulsun istiyorum. Dosya ektedir.

 

[Ömer]

Merhaba,

Sayfalara_Aktar kodunu çalıştırın.

Sub Sayfalara_Aktar()

    Dim S1 As Worksheet, i As Long, syf As String, son As Long
    
    Set S1 = Sheets("Sayfa1") 'verilerin bulunduğu sayfa

    Application.ScreenUpdating = False
    Sayfa_Sil
    S1.Select
    
    For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
        syf = Trim(S1.Cells(i, "D"))
        If Not varmi(syf) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = syf
            S1.Range("A1:J1").Copy Sheets(syf).Range("A1")
        End If
        son = Sheets(syf).Cells(Rows.Count, "D").End(xlUp).Row + 1
        S1.Cells(i, "A").Resize(1, 10).Copy Sheets(syf).Cells(son, "A")
        Cells.EntireColumn.AutoFit
    Next i

    S1.Select
    MsgBox "İşlem Tamam"
    Application.ScreenUpdating = True

End Sub

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

Sub Sayfa_Sil()
 
    Dim j As Integer
    
    Application.DisplayAlerts = False
    
    For j = Worksheets.Count To 1 Step -1
        With Sheets(j)
            If .Name <> "Sayfa1" Then 'verilerin bulunduğu sayfa
                .Delete
            End If
        End With
    Next j
    
    Application.DisplayAlerts = True
End Sub

.

 

[darkvenue]

Merhabalar,
Bu makroda sayfa 1 haricindeki sayfaları silip yeniden D sütünundaki isimlere göre sayfalar oluşturuyor. Benim merak ettiğim örnek olarak D sütünunda yazmayan isimlerdeki sayfaların silinmesini nasıl engelleyebiliriz. Sadece D sütünundak isimlerdeki sayfaların silinip oluşturulması için kodda nasıl bir değişiklik yapılması gerekir. İyi çalışmalar

 

[systran]

sayfalara_aktar() alt programını şu şekilde değiştirin. Sayfa_sil() kodlarına gerek kalmıyor.

Sub Sayfalara_Aktar()

    Dim S1 As Worksheet, i As Long, syf As String, son As Long
    
    Set S1 = Sheets("Sayfa1") 'verilerin bulunduğu sayfa

    Application.ScreenUpdating = False
    S1.Select
    
    For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
        syf = Trim(S1.Cells(i, "D"))
        If varmi(syf) Then 'sayfa mevcut ise sil yeniden oluştur
            Application.DisplayAlerts = False
            Sheets(syf).Delete
            Application.DisplayAlerts = True
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = syf
            S1.Range("A1:J1").Copy Sheets(syf).Range("A1")
        Else   'sayfa mevcut değilse ekle
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = syf
            S1.Range("A1:J1").Copy Sheets(syf).Range("A1")
        End If
        ss = Worksheets(syf).Cells(Rows.Count, "D").End(xlUp).Row
        son = ss + 1
        S1.Cells(i, "A").Resize(1, 10).Copy Sheets(syf).Cells(son, "A")
        Cells.EntireColumn.AutoFit
    Next i

    S1.Select
    MsgBox "İşlem Tamam"
    Application.ScreenUpdating = True

End Sub

 

[Antepliislam]

iLGİNİZE ÇOK TEŞEKKÜR EDERİM TAM İSTEDİGİM GİBİ OLMUŞ

 

[darkvenue]

Merhabalar bu kodda surada hata veriyor .. kontrol edebilir misiniz ?
If varmi(syf) Then 'sayfa mevcut ise sil yeniden oluştur...

 

[systran]

Merhabalar bu kodda surada hata veriyor .. kontrol edebilir misiniz ?
If varmi(syf) Then 'sayfa mevcut ise sil yeniden oluştur...

kaynak dosyadaki "sayfa1" haricindeki diğer sayfaları silin, sonra kodu çalıştırın.

 

[darkvenue]

varmi da compile error: Sub or function not defined hatası veriyor. Birde sayfa 1 de D sütünuna göre oluşturulacak sayfalar silinip tekrardan oluşturulacak ancak eğer dosya içerisinde sayfa 1 haricinde D sütünda ismi yazmayan sayfalar aynen korunacak şekilde bir koda ihtiyacım var.

 

[systran]

bu fonksiyonu silmişsiniz.

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

sayfaları bir kez silin çünkü bazı sayfaların adları D sütunu ile eşleşmiyor. İŞ BANKASI sayfada T. İŞBANKASI, FİNANS v.b. yazım yanlışları var.

 

[darkvenue]

Tam olarak nereye ilave edilmesi gerekiyor acaba

bu fonksiyonu silmişsiniz.

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

sayfaları bir kez silin çünkü bazı sayfaların adları D sütunu ile eşleşmiyor. İŞ BANKASI sayfada T. İŞBANKASI, FİNANS v.b. yazım yanlışları var.

 

[darkvenue]

Bu fonksiyonu tam olarak makronun neresine ilave etmeliyim. Çalıştıramadım.

 

[systran]

aşağıdaki şekilde olacak.

Sub Sayfalara_Aktar()
...
End Sub

Function varmi(adi As String) As Boolean
...
End Function

 

[darkvenue]

Çok Teşekkür ederim.