Adres defteri

[zehfeysal]

İyi akşamlar.
Bir Adres dosyası oluşturmak istiyoruz. A sütunundaki şehir bilgisine göre bütün satırı o şehre açılan sayfaya da yazsın.
Yardımcı olacaklara şimdiden teşekkürler.

 

[TanerSaydam]

Bunu link olarak da eklerseniz, yardımcı olmaya çalışayım.

 

[zehfeysal]

Bunu link olarak da eklerseniz, yardımcı olmaya çalışayım.

Nasıl yapıldığı hakkında fikrim yok

 

[YUSUF44]

Genel sayfa/sekme ismine sağ tıklayın ve Kod görüntüle deyin. aşağıdaki kodları açılan sayfaya yapıştırın:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A3:K" & Cells(Rows.Count, "A").End(3).Row + 1)) Is Nothing Then Exit Sub
a = Target.Row

If WorksheetFunction.CountBlank(Range("A" & a & ":K" & a)) = 0 Then
    sayfa = Cells(a, "A").Value
    Range("A" & a & ":K" & a).Copy Sheets(sayfa).Cells(Sheets(sayfa).Cells(Rows.Count, "A").End(3).Row + 1, "A")
End If

End Sub

 

[cems]

Nasıl yapıldığı hakkında fikrim yok

www.dosya.tc gibi bir dış servera zipleyerek yükleyip verilen linki burada paylaşabilirsiniz

 

[Necdet]

Merhaba,

Alternatif olsun.

Tüm sayfayı kontrol eder, L sütununu boş gördüğü an o satırı ilgili sayfaya aktarır, Sayfa yoksa açar.

GENEL sayfasında aktardığını belli etmek için L sütununa Çentik atar. Bu sütunun font ismini Wingdings olarak ayarlarsanız çentiği görebilirsiniz.

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub SayfalaraAktar()

    Dim i   As Long, _
        j   As Long, _
        Syf As String, _
        ShG As Worksheet, _
        ShY As Worksheet
    
    Set ShG = Sheets("GENEL")
    
    Application.ScreenUpdating = False
    
    For i = 3 To ShG.Cells(Rows.Count, "A").End(3).Row
    
        If Cells(i, "L") = "" Then
        
            Syf = Trim(ShG.Cells(i, "A"))
            If Not SayfaVarYok(Syf) Then
               Set ShY = Sheets.Add
               ShY.Move After:=Worksheets(Worksheets.Count)
               ShY.Name = Syf
               ShG.Range("A1:K2").Copy ShY.Range("A1")
             End If
            
            j = Sheets(Syf).Cells(Rows.Count, "A").End(3).Row + 1
            ShG.Range("A" & i & ":K" & i).Copy Sheets(Syf).Range("A" & j)
            ShG.Cells(i, "L") = "ü"
            
       End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

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

 

[zehfeysal]

Arkadaşlar çok teşekkür ederim. İş yerinde server engellediği için teşekkür mesajım gecikti. İki çalışmayı da denedim. Nedense Yusuf44 ün çalışmasını uygulayamadım.Necdet Yeşertener'in çalışmasını uygulayabildim. İlgilendiğiniz için tekrar teşekkürler.