çalışma sayfasını X sütununa göre çalışma sayfası oluşturmak

[deryabas80]

merhabalar,

Ekteki dosyada B sutunundaki ilçelere göre ayrı ayrı çalışma sayfasını nasıl yapabilirim.

Teşekkürler....

 

[Ömer]

Merhaba,

Bu şekilde deneyin. Module kopyalayıp çalıştırırsınız.

Sub Sayfa_Ac()
 
    Dim i As Long, sayfa As String, j As Integer, So As Worksheet
 
    Set So = Sheets("örneklem")
 
    Application.ScreenUpdating = False
    So.Select
 
    Application.DisplayAlerts = False
     For j = Worksheets.Count To 1 Step -1
        With Sheets(j)
            If .Name <> "örneklem" Then
                .Delete
            End If
        End With
     Next j
    Application.DisplayAlerts = True
 
    With CreateObject("Scripting.Dictionary")
        For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
            If Not Cells(i, "B") = Empty Then
                sayfa = So.Cells(i, "B")
                If .exists(sayfa) = False Then
                    .Add sayfa, Nothing
                    Sheets.Add After:=Worksheets(Worksheets.Count)
                    ActiveSheet.Name = sayfa
                    So.Select
                End If
            End If
        Next i
    End With
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[deryabas80]

merhaba Ömer Bey,

Kod yazmadan nasıl yapabilirim. Katkılarınız için çok teşekkür ederim.

 

[Ömer]

Ekle/Çalışma Sayfası menüsüden sayfa ekleyip isimlerini değiştirmeniz gerekir.

 

[deryabas80]

çalışma sayfasındaki verileri birden fazla çalışma sayfasında göre sınıflandırmak

merhabalar,

Örneklem olarak ana sheet dosyasını ekteki gibi ilçelere göre sheet'lere ayrılmıştır.
Örneklem ana sheetin üzerinden nasıl makro yazarak bunu aynı şekilde sheetlere ayırabilirim.

Teşekkürler.

 

[Ömer]

merhabalar,

Örneklem olarak ana sheet dosyasını ekteki gibi ilçelere göre sheet'lere ayrılmıştır.
Örneklem ana sheetin üzerinden nasıl makro yazarak bunu aynı şekilde sheetlere ayırabilirim.

Teşekkürler.

Bu şekilde deneyin.

Sub Sayfa_Ac()
 
    Dim i As Long, sayfa As String, j As Integer, So As Worksheet, son As Long
 
    Set So = Sheets("örneklem")
 
    Application.ScreenUpdating = False
    So.Select
 
    Application.DisplayAlerts = False
     For j = Worksheets.Count To 1 Step -1
        With Sheets(j)
            If .Name <> "örneklem" Then
                .Delete
            End If
        End With
     Next j
    Application.DisplayAlerts = True
 
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        If Not Cells(i, "B") = Empty Then
            sayfa = So.Cells(i, "B")
            If Not varmi(sayfa) Then
                Sheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = sayfa
                son = Cells(Rows.Count, "A").End(xlUp).Row + 1
                Cells(son, "A") = So.Cells(i, "A")
                Cells(son, "B") = So.Cells(i, "B")
                So.Select
            Else
                son = Sheets(sayfa).Cells(Rows.Count, "A").End(xlUp).Row + 1
                Sheets(sayfa).Cells(son, "A") = So.Cells(i, "A")
                Sheets(sayfa).Cells(son, "B") = So.Cells(i, "B")
                So.Select
            End If
        End If
    Next i
 
    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

.

 

[deryabas80]

teşekkür eder, iyi çalışmalar dilerim.

 

[deryabas80]

Ömer bey,

çalışma sayfası sadece A ve B sütunundan ibaret değilse; örneğin K sütununa kadar veri varsa;

bu durumda yazmış olduğunuz kod kısmında nerde değişiklik yaparak bu uygulamayı çalıştırabilirim.

ilginiz ve katkılarınız için teşekker ederim.

Saygılarımla.

 

[Ömer]

Hangi sütuna göre sayfa açılacak, ve açılan sayfalara hangi sütun aralıkları aktarılacak.

Örneğin: B sütununa göre sayfa açılacak, A:K arası açılan sayfalara aktarılacak. Şeklinde örnek verirmisiniz.

 

[deryabas80]

B sutununa gore sayfa acilacak, A:K arası tum sutunlar aktarılacak.

tesekkür ederim.

 

[Ömer]

B sutununa gore sayfa acilacak, A:K arası tum sutunlar aktarılacak.

tesekkür ederim.

Bu şekilde deneyin.

Sub Sayfa_Ac()
 
    Dim i As Long, sayfa As String, j As Integer, So As Worksheet, son As Long
 
    Set So = Sheets("örneklem")
 
    Application.ScreenUpdating = False
    So.Select
 
    Application.DisplayAlerts = False
     For j = Worksheets.Count To 1 Step -1
        With Sheets(j)
            If .Name <> "örneklem" Then
                .Delete
            End If
        End With
     Next j
    Application.DisplayAlerts = True
 
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        If Not Cells(i, "B") = Empty Then
            sayfa = So.Cells(i, "B")
            If Not varmi(sayfa) Then
                Sheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = sayfa
               [COLOR=red] So.Range("A1:K1").Copy Range("A1")[/COLOR]
                son = Cells(Rows.Count, "A").End(xlUp).Row + 1
                So.Range(So.Cells(i, "A"), So.Cells(i, "K")).Copy Cells(son, "A")
                So.Select
            Else
                son = Sheets(sayfa).Cells(Rows.Count, "A").End(xlUp).Row + 1
                So.Range(So.Cells(i, "A"), So.Cells(i, "K")).Copy Sheets(sayfa).Cells(son, "A")
                So.Select
            End If
        End If
    Next i
 
    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

.

 

[deryabas80]

Ömer bey, uyguladım fakat, aşağıdaki hatayı vermektedir.

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

Kusura bakmayın lütfen, tekrar katkılarınız için teşekkür ederim.

 

[Ömer]

End Function.

sondaki nokta işaretini fazladan koymuşsunuz. Noktayı silerseniz büyük ihtimalle düzelecektir.

 

[deryabas80]

merhabalar Ömer bey,

haklısınız.
ilk satırı başlık olarak diğer sheetlerde nasıl oluşturabiliriz.(özetle il adı ve ilçe adı diğer sheetlerde başlık olarak gözükmüyor?)

for i=2 to Cells.......2 yerine 1 yazdım fakat olmadı.
teşekkürler.

 

[Ömer]

#11 numaralı mesajda ilave satırı kırmızı ile işaretledim.