Mükerrer olanları farklı sayfalara aktarma

Katılım
13 Ocak 2017
Mesajlar
158
Excel Vers. ve Dili
2010 türkçe
Merhaba,

Eklediğim dosya da B sütununda yer alan verileri İl isimlerine göre filtreleyip, her bir il için ayrı sayfalara kopyalaması ve kopyalanan örneğin İstanbul ise sayfa isminin de İstanbul olması mümkünmüdür?

Hergün bununla çokça uğraşıyoruz yardımcı olabilirseniz sevinirim

teşekkürler
 

Ekli dosyalar

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Merhaba.

Alt taraftan Sayfa1 adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağdaki boş alana aşağıdaki kod blokunu yapıştırıp çalıştırın.
Dikkat: Kod önce, varsa ismi Sayfa1'den farklı olan sayfaları siler, ardından istenilen işlemi yapar.
Gerçek belgenizde de verilerin
1'inci satırdan başladığı (başlık satırının olmadığı) varsayıldı.
Rich (BB code):
Sub BARAN()
Set S1 = Sheets("Sayfa1")
If S1.AutoFilterMode = True Then S1.AutoFilterMode = False
Application.DisplayAlerts = False
For Each shf In ThisWorkbook.Sheets
    If shf.Name <> "Sayfa1" Then shf.Delete
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
S1.Rows("1:1").Insert Shift:=xlDown
If S1.[A1] = "İLÇE" Then: S1.Rows("1:1").Delete Shift:=xlUp
S1.[A1] = "İLÇE": S1.[B1] = "İL"
son = S1.Cells(Rows.Count, 1).End(3).Row
For sat = 2 To son
    If WorksheetFunction.CountIf(S1.Range("B2:B" & sat), S1.Cells(sat, 2)) = 1 Then
    S1.Range("A1:B" & Rows.Count).AutoFilter Field:=2, Criteria1:=S1.Cells(sat, 2)
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = S1.Cells(sat, 2)
    S1.Range("A2:B" & son).Copy ActiveSheet.[A1]
    End If
Next
S1.Rows("1:1").Delete Shift:=xlUp
S1.Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox Sheets.Count - 1 & " adet sayfa oluşturularak ilçeler aktarıldı.", vbInformation, "..:: Ömer BARAN ::.."
End Sub
 
Son düzenleme:
Katılım
13 Ocak 2017
Mesajlar
158
Excel Vers. ve Dili
2010 türkçe
Merhaba.

Alt taraftan Sayfa1 adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağdaki boş alana aşağıdaki kod blokunu yapıştırıp çalıştırın.
Dikkat: Kod önce, varsa ismi Sayfa1'den farklı olan sayfaları siler, ardından istenilen işlemi yapar.
Gerçek belgenizde de verilerin
1'inci satırdan başladığı (başlık satırının olmadığı) varsayıldı.
Rich (BB code):
Sub BARAN()
Set S1 = Sheets("Sayfa1")
If S1.AutoFilterMode = True Then S1.AutoFilterMode = False
Application.DisplayAlerts = False
For Each shf In ThisWorkbook.Sheets
    If shf.Name <> "Sayfa1" Then shf.Delete
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
S1.Rows("1:1").Insert Shift:=xlDown
If S1.[A1] = "İLÇE" Then: S1.Rows("1:1").Delete Shift:=xlUp
S1.[A1] = "İLÇE": S1.[B1] = "İL"
son = S1.Cells(Rows.Count, 1).End(3).Row
For sat = 2 To son
    If WorksheetFunction.CountIf(S1.Range("B2:B" & sat), S1.Cells(sat, 2)) = 1 Then
    S1.Range("A1:B" & Rows.Count).AutoFilter Field:=2, Criteria1:=S1.Cells(sat, 2)
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = S1.Cells(sat, 2)
    S1.Range("A2:A" & son).Copy ActiveSheet.[A1]
    End If
Next
S1.Rows("1:1").Delete Shift:=xlUp
S1.Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox Sheets.Count - 1 & " adet sayfa oluşturularak ilçeler aktarıldı.", vbInformation, "..:: Ömer BARAN ::.."
End Sub
Ömer Bey Merhaba,

öncelikle bu kadar uğraşıp emek verdiğiniz için sonsuz teşekkürler.
Şuan ki hali ile mükemmel çalışıyor,problem yok sadece ilave bir sorum daha olacaktı.
örneğin sayfa isimlerini açıyor ve istanbul karşılığına gelenleri aktarıyor o şekilde değilde istanbul olarak filtrelenen kısımdan yani a ve b sütunlarında ki bilgileri olduğu gibi aktarabilirmi acaba?
 

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Önceki cevabımdaki kod'da sütun adı değişikiğini yaptım (kırmızı büyük karakterli kısım).
Sayfayı yenileyerek kontrol edin.
 
Son düzenleme:

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Kolay gelsin.
.
 
Üst