Filitre yaparak dosya içine kaydetme

search77 · Bugün 13:02

Arkadaşlar merhaba,
Aşağıdaki kod örneğin küçük bir datada sorunsuz çalışıyor (örneğin 10 satırlık veri)
Fakat yüksek satırlı bir datada (örneğin 20 bin satırlı veri) çalışmıyor, hata vermiyor ama çok bekletiyor ve sonra işlemi bitirmiş gibi yapıyor fakat sonucu vermiyor

Bu konuda ne yapabiliriz, yüksek verilerin olduğu satırlarda da işlemi yapması için kodu nasıl düzenlemeliyiz.
Şimdiden yardımcı olacak arkadaşlar için çok çok teşekkürler.

Sub SayfaKaydet()

Dim S1 As Worksheet, S2 As Worksheet, son As Long, dosya As String
Dim i As Long, IlkAdres As Variant, c As Range

Set S1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")

Application.ScreenUpdating = False

S1.Range("A1:L1").Copy S2.Range("A1")
S1.[O:O].Clear
S2.Range("A2:L" & Rows.Count).ClearContents

S1.Range("B:B").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("O1"), Unique:=True

sat = 2
For i = 2 To S1.Cells(Rows.Count, "O").End(xlUp).Row
With S1.Range("B:B")
Set c = .Find(S1.Cells(i, "O"), , LookIn:=xlValues)
If Not c Is Nothing Then
IlkAdres = c.Address
Do

If S2.Range("A2") = "" Then
sat = 2
End If

S1.Range("A" & c.Row & ":L" & c.Row).Copy S2.Range("A" & sat)
sat = sat + 1

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> IlkAdres
End If
End With

S2.Select
dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
"\Dosya" & Application.PathSeparator & S2.[B2] & ".xlsx"

ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=dosya
ActiveWorkbook.Close

S2.Columns("A:L").EntireColumn.AutoFit
S2.Range("A2:L" & Rows.Count).ClearContents

Next i

S1.Select
[O:O].Clear

Application.ScreenUpdating = True

End Sub

Korhan Ayhan · Bugün 13:23

Küçük bir örnek dosya ile yapmak istediğiniz işlemi açıklarmısınız?

search77 · Bugün 13:33

Korhan Bey,

Maalesef çalıştığım kurum güvenlik yetkileri nedeniyle dosya ekliyemiyorum.

Amacım şu; A ile L kolonları arasında bir datam var, teker teker B kolonundaki verilere göre filitre yapıp sonuçları bir klasöre kaydetmek

pitchoute · Bugün 13:37

Merhaba, yedek aldıktan sonra deneyip hız konusunda sonucu paylaşabilir misiniz;

Kod:

Sub SayfaKaydet()
    Dim S1 As Worksheet, S2 As Worksheet, son As Long, dosya As String
    Dim i As Long, IlkAdres As Variant, c As Range
    Dim benzersizDegerler As Object
    Dim deger As Variant
    Dim satir As Long, hedefSat As Long
    
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    S1.Range("A1:L1").Copy S2.Range("A1")
    S1.Range("O:O").ClearContents
    S2.Range("A2:L" & Rows.Count).ClearContents
    Set benzersizDegerler = CreateObject("Scripting.Dictionary")
    son = S1.Cells(S1.Rows.Count, "B").End(xlUp).Row
    
    For i = 2 To son
        deger = S1.Cells(i, "B").Value
        If Not benzersizDegerler.exists(deger) Then
            benzersizDegerler.Add deger, 1
        End If
    Next i
    
    For Each deger In benzersizDegerler.Keys
        S2.Range("A2:L" & Rows.Count).ClearContents
        hedefSat = 2
        
        For satir = 2 To son
            If S1.Cells(satir, "B").Value = deger Then
                S1.Range("A" & satir & ":L" & satir).Copy S2.Range("A" & hedefSat)
                hedefSat = hedefSat + 1
            End If
        Next satir
        
        S2.Select
        dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
                "\Dosya\" & deger & ".xlsx"
        CreateFolderIfNotExists CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Dosya\"
        S2.Copy
        ActiveWorkbook.SaveAs Filename:=dosya
        ActiveWorkbook.Close
    Next deger

    S2.Columns("A:L").EntireColumn.AutoFit
    S2.Range("A2:L" & Rows.Count).ClearContents
    S1.Select
    S1.Range("O:O").ClearContents
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    MsgBox "İşlem tamamlandı.", vbInformation
End Sub

Function CreateFolderIfNotExists(folderPath As String) As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists(folderPath) Then
        fso.CreateFolder folderPath
    End If
    CreateFolderIfNotExists = True
End Function

search77 · Bugün 14:47

selamlar,
maalesef 10 binlik datada 10 dk dır bekliyorum henüz aksiyon alamadı

muhasebeciyiz · Bugün 15:22

Kod:

Sub SayfaKaydetHizli()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim son As Long, dosya As String
    Dim veri As Variant, benzersizDegerler As Object
    Dim deger As Variant, hedefKlasor As String
    Dim i As Long, j As Long
    Dim yeniSayfa As Worksheet

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set S1 = ThisWorkbook.Sheets("Sheet1")
    Set S2 = ThisWorkbook.Sheets("Sheet2")

    hedefKlasor = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Dosya\"
    CreateFolderIfNotExists hedefKlasor

    S2.Cells.ClearContents
    S1.Range("A1:L1").Copy S2.Range("A1")

    son = S1.Cells(S1.Rows.Count, "B").End(xlUp).Row
    veri = S1.Range("A1:L" & son).Value

    Set benzersizDegerler = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(veri, 1)
        deger = veri(i, 2)
        If Not benzersizDegerler.exists(deger) Then
            benzersizDegerler.Add deger, 1
        End If
    Next i

    For Each deger In benzersizDegerler.Keys
        
        Set yeniSayfa = Workbooks.Add.Sheets(1)
        S1.Range("A1:L1").Copy yeniSayfa.Range("A1")
        
        For i = 2 To UBound(veri, 1)
            If veri(i, 2) = deger Then
                yeniSayfa.Cells(yeniSayfa.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 12).Value = _
                    S1.Cells(i, 1).Resize(1, 12).Value
            End If
        Next i

        dosya = hedefKlasor & Replace(deger, "/", "-") & ".xlsx"
        With yeniSayfa.Parent
            .SaveAs Filename:=dosya, FileFormat:=xlOpenXMLWorkbook
            .Close SaveChanges:=False
        End With
        Set yeniSayfa = Nothing
    Next deger

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    MsgBox "İşlem tamamlandı.", vbInformation
End Sub

Function CreateFolderIfNotExists(folderPath As String) As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(folderPath) Then
        fso.CreateFolder folderPath
    End If
    CreateFolderIfNotExists = True
End Function

Bu değişikliklerle kodunuzun 10 bin satırlık bir veri için çok daha kısa sürede tamamlanması beklenir. Lütfen bu yeni versiyonu deneyip sonucu paylaşır mısınız?

search77 · Bugün 15:38

S2.Cells("A2:L" & Rows.Count).ClearContents ' Bir sonraki benzersiz değer için Sheet2'yi temizle

Debug verdi bu kısımda ama

mustafa1205 · Bugün 16:59

Yedek alıp bir deneyin isterseniz

Sub SayfaKaydet_Hizli()

Dim S1 As Worksheet, S2 As Worksheet
Dim veri As Variant, i As Long, j As Long
Dim benzersiz As Object
Dim sat As Long, dosya As String
Dim yol As String
Dim anahtar As Variant

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False

Set S1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")

' Klasör oluşturulacak mı kontrol
yol = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Dosya"
If Dir(yol, vbDirectory) = "" Then MkDir yol

' Veriyi Array'e al
veri = S1.Range("A1:L" & S1.Cells(S1.Rows.Count, "B").End(xlUp).Row).Value

' Benzersiz değerleri Dictionary ile bul
Set benzersiz = CreateObject("Scripting.Dictionary")

For i = 2 To UBound(veri)
If Not benzersiz.exists(veri(i, 2)) And veri(i, 2) <> "" Then
benzersiz.Add veri(i, 2), 1
End If
Next i

' Başlıkları kopyala
S2.Range("A1:L1").Value = S1.Range("A1:L1").Value

' Her benzersiz değer için dosya oluştur
For Each anahtar In benzersiz.Keys
' S2 temizle
S2.Range("A2:L" & S2.Rows.Count).ClearContents

sat = 2

' İlgili kayıtları yaz
For i = 2 To UBound(veri)
If veri(i, 2) = anahtar Then
For j = 1 To 12
S2.Cells(sat, j).Value = veri(i, j)
Next j
sat = sat + 1
End If
Next i

' Kayıt varsa dosya kaydet
If S2.Cells(2, 2).Value <> "" Then
dosya = yol & "\" & S2.Cells(2, 2).Value & ".xlsx"
S2.Copy
ActiveWorkbook.SaveAs Filename:=dosya, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False
End If
Next anahtar

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True

Set benzersiz = Nothing

MsgBox "İşlem tamamlandı.", vbInformation

End Sub

muhasebeciyiz · Bugün 17:09

Kodda düzenleme yaptım denermisiniz

haliliyas · Bugün 20:11

benzersiz değer oluşturma kodu

Kod:

Sub BenzersizVeri()
    Set wsLst = ThisWorkbook.Sheets("sheet1")
    Set wsDkm = ThisWorkbook.Sheets("sheet2") ': wsDkm.Cells.Clear
 Application.ScreenUpdating = False
    wsLst.Range("B:B").AdvancedFilter Action:=xlFilterCopy, _
                                      CopyToRange:=wsDkm.Range("A1"), Unique:=True
        sonSatir = wsDkm.Cells(wsDkm.Rows.Count, "A").End(xlUp).Row
dz = wsDkm.Range("A2:A" & sonSatir).Value2
    For x = 1 To UBound(dz)
       Filter_VeriCek CStr(dz(x, 1))
    Next x

Application.ScreenUpdating = True
End Sub

benzersiz değere göre kitap oluşturma kodu

Kod:

Sub Filter_VeriCek(xBenzersiz As String)
    Dim wsLst As Worksheet
    Dim wsDkm As Worksheet
    Dim tarihSutunu As Range
    Dim sonSatir As Long
    
    ' Sayfaları tanımla
    Set wsLst = ThisWorkbook.Sheets("sheet1")

        ' Son satırı bul
        sonSatir = wsLst.Cells(wsLst.Rows.Count, "A").End(xlUp).Row
   Set wsDkm = ThisWorkbook.Sheets("sheet2")
       wsDkm.UsedRange.ClearContents
        
        ' Otomatik filtre uygula
        With wsLst
            .Range("A1:M" & sonSatir).AutoFilter Field:=2, Criteria1:="=" & xBenzersiz
            .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Destination:=wsDkm.Range("A1") 'kopyala
            .AutoFilterMode = False
        End With
'____________________________________________________
    ' Kaydedilecek dosya yolu (ben aynı dizindeki "\Dosya\" gerekirse değiştirin)
    kayitYolu = ThisWorkbook.Path & "\Dosya\" & xBenzersiz & ".xlsx"
    
    ' Sayfayı kopyala ve yeni bir kitap olarak aç
    wsDkm.Copy
    Set yeniKitap = ActiveWorkbook
        yeniKitap.SaveAs Filename:=kayitYolu, FileFormat:=xlOpenXMLWorkbook
        yeniKitap.Close SaveChanges:=False
End Sub

Filitre yaparak dosya içine kaydetme

Administrator