• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Dosya ve sheetleri filtreleyerek farklı dosyalara dağıtma

  • Konbuyu başlatan Konbuyu başlatan knuur
  • Başlangıç tarihi Başlangıç tarihi
K

knuur

Katılım
10 Haziran 2014
Mesajlar
8
Excel Vers. ve Dili
excel 2013 ingilizce
Merhaba
Ekte örnek bir dosyam var. Ana dosya diyelim.
Yapmak istediğim şu.
Ana dosyadan Data1 sayfasında İngiltere filtreleyip yeni bir dosyaya yapıştıracağım. Yeni dosyada sayfa adı yine data1 olacak. Sonrasında ana dosyada data2 sayfasında yine "ingiltere" filtreleyerek biraz önce açılan dosyada yeni bir sayfaya yapıştıracağım ve adı da data2 olacak. Sonrasında yine ana dosyada data 3 sayfası için aynı işlemi yapacağım. Sonrasında bu döngü bitince yeni dosyamın adı ingiltere olacak. Bu işlemi ülke kolonundaki tüm ülkeler için yapacağım.Döngüleri bir türlü hazırlayamadım. Bana yardımcı olur musunuz?
 
knuur' Alıntı:
Merhaba
Ekte örnek bir dosyam var. Ana dosya diyelim.
Yapmak istediğim şu.
Ana dosyadan Data1 sayfasında İngiltere filtreleyip yeni bir dosyaya yapıştıracağım. Yeni dosyada sayfa adı yine data1 olacak. Sonrasında ana dosyada data2 sayfasında yine "ingiltere" filtreleyerek biraz önce açılan dosyada yeni bir sayfaya yapıştıracağım ve adı da data2 olacak. Sonrasında yine ana dosyada data 3 sayfası için aynı işlemi yapacağım. Sonrasında bu döngü bitince yeni dosyamın adı ingiltere olacak. Bu işlemi ülke kolonundaki tüm ülkeler için yapacağım.Döngüleri bir türlü hazırlayamadım. Bana yardımcı olur musunuz?
Genişletmek için tıkla ...
Bu arada örnek dosyayı yükleyemiyorum
 
Dosyanız linktedir.:cool:
Ayni dosyadan varsa hata verir.
Önce o dosyayı silmelisiniz.
Mesela İngiltere dosyası varsa ingiltere süzecekseniz
Ayni klasörün içersindeyseler onu ya başka bir yere taşıyın veya silin.:cool:

DOSYAYI INDIR

Kod: 
Sub ulkesuz_59()
Dim wb As Workbook, j As Integer
Workbooks.Add
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Ingiltere.xlsx"
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
For j = ActiveWorkbook.Sheets.Count To 2 Step -1
    ActiveWorkbook.Sheets(j).Delete
Next
Application.DisplayAlerts = True
ThisWorkbook.Activate
For j = 1 To Worksheets.Count
    wb.Worksheets.Add after:=wb.Sheets(wb.Worksheets.Count)
    Set sh = wb.Sheets(wb.Worksheets.Count)
    sh.Name = Sheets(j).Name
    Worksheets(j).Range("a1").AutoFilter field:=1, Criteria1:="İngiltere"
    Worksheets(j).Range("A1").CurrentRegion.Copy sh.Range("A1")
Next
wb.Close True
MsgBox "İşlem tamamlanmıştır.", vbOKOnly + vbInformation, Application.UserName
End Sub
 
Yardımınız için çok teşekkür ederim.
Birşey sormak istiyorum.
Şimdi ben ana dosyada bütün sayfalarda ingiltere süzerek yeni bir dosyaya sayfalar halinde yapıştırıp ingiltere diye kaydetmek istiyorum. Yazdığınız kod ile bunu yapabliyorum. Ancak döngüyü İngiltere den sonra fransa ve diğer ülkeler için de yapmak istiyorum. Bunların başına nasıl bir döngü eklemem gerekiyor?
 
O zaman kodlarda ilave yapmam gerek.
Ama sanırım bu gün bakamam.meşgulum.:cool:
 
Orion1' Alıntı:
O zaman kodlarda ilave yapmam gerek.
Ama sanırım bu gün bakamam.meşgulum.:cool:
Genişletmek için tıkla ...

Müsait olduğunuzda bakabilirseniz çok sevinirim.
Veya döngüyü nereden başlatmam gerektiği ile alakalı bana ipucu verebilseniz ben kendim de denemek isterim.
 
Müsait olduğumda bakarım.
Sayfalarda döngüye girip benzersiz olan ulkeleri createobject scriptingdictionary ile almak.
Sonra onlara dosya oluşturmak,lazım.:cool:
 
Orion1' Alıntı:
Müsait olduğumda bakarım.
Sayfalarda döngüye girip benzersiz olan ulkeleri createobject scriptingdictionary ile almak.
Sonra onlara dosya oluşturmak,lazım.:cool:
Genişletmek için tıkla ...

sanırım beni aşar :)
Sizin kadar uzman değilim.
Müsait olduğunuzda bakabilirseniz çok sevinirim.
Desteğiniz için teşekkürler
 
Dosyanız linktedir.:cool:

DOSYAYI INDIR

Kod: 
Sub ulkesuz_59()
Dim wb As Workbook, j As Integer, i As Long, x As Long
Dim z As Object, liste(), vkey
Set z = CreateObject("scripting.dictionary")
For x = 1 To Worksheets.Count
    liste = Sheets(x).Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    For i = 1 To UBound(liste)
        If Not z.exists(liste(i, 1)) Then
            z.Add liste(i, 1), Nothing
        End If
    Next i
Next x
Erase liste()
If z.Count < 1 Then
    MsgBox "Oluşturulacak ülke bulunamadı!!", vbCritical, "UYARI"
    Exit Sub
End If
For Each vkey In z.keys
    Workbooks.Add
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & vkey & ".xlsx"
    Set wb = ActiveWorkbook
    Application.DisplayAlerts = False
    For j = ActiveWorkbook.Sheets.Count To 2 Step -1
        ActiveWorkbook.Sheets(j).Delete
    Next
    Application.DisplayAlerts = True
    ThisWorkbook.Activate
    For j = 1 To Worksheets.Count
        wb.Worksheets.Add after:=wb.Sheets(wb.Worksheets.Count)
        Set sh = wb.Sheets(wb.Worksheets.Count)
        sh.Name = Sheets(j).Name
        Worksheets(j).Range("a1").AutoFilter field:=1, Criteria1:=vkey
        Worksheets(j).Range("A1").CurrentRegion.Copy sh.Range("A1")
    Next
    wb.Close True
Next vkey
MsgBox "İşlem tamamlanmıştır.", vbOKOnly + vbInformation, Application.UserName
End Sub
 
Alternatif,

Yeni oluşan dosyalar bu işlemi yaptığınız dosyanın bulunduğu yere kayıt edilir.

Kod: 
Option Explicit

Sub Verileri_Dosyalara_Aktar()
    Dim K1 As Workbook, Sayfa As Worksheet, Son As Long, Veri As Variant, X As Long, Yol As String
    Dim Liste As Collection, Kriter As Variant, XL_App As Object, K2 As Object, S1 As Object, Kontrol As Boolean

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With

    Set K1 = ThisWorkbook
    Yol = K1.Path & Application.PathSeparator
    Set Liste = New Collection

    On Error Resume Next
    
    For Each Sayfa In K1.Worksheets
        Sayfa.ShowAllData
        Son = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row
        Veri = Sayfa.Range("A2:A" & Son).Value
        For X = 0 To UBound(Veri)
            Liste.Add Veri(X, 1), CStr(Veri(X, 1))
        Next
    Next
    
    On Error GoTo 0
    
    Set XL_App = CreateObject("Excel.Application")
    XL_App.Visible = False
    XL_App.DisplayAlerts = False
    
    For Each Kriter In Liste
        Set K2 = XL_App.Workbooks.Add()
        Set S1 = K2.Worksheets(1)
        Kontrol = True
        For Each Sayfa In K1.Worksheets
            If Kontrol = False Then Set S1 = K2.Worksheets.Add(, K2.Worksheets(K2.Worksheets.Count))
            Sayfa.Range("A1:F" & Sayfa.Rows.Count).AutoFilter 1, Kriter
            Sayfa.Range("A1").CurrentRegion.Copy
            S1.Range("A1").PasteSpecial xlValues
            S1.Cells.EntireColumn.AutoFit
            S1.Range("A1").Select
            S1.Name = Sayfa.Name
            Kontrol = False
            Sayfa.ShowAllData
        Next
        K2.Sheets(1).Select
        K2.SaveAs Yol & Kriter & ".xlsx", FileFormat:=51
        K2.Close
    Next
    
    XL_App.Quit
    
    Set Liste = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set XL_App = Nothing
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
    End With
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Çok tşeekkür ederim.
Cidden çok işime yaradı.
YEni birşey de öğrenmiş oldum.
Ellerinize emeğinize sağlık
 
knuur' Alıntı:
Çok tşeekkür ederim.
Cidden çok işime yaradı.
YEni birşey de öğrenmiş oldum.
Ellerinize emeğinize sağlık
Genişletmek için tıkla ...
Rica ederim.
İyi çalışmalar.:cool:
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst