Ana hesaplara ayırmada sorun

[1903emre34@gmail.com]

Merhaba,

Ekteki dosyada, 600 hesabı ile sayfa1 arasında uyumsuz ortaya çıktı, nedeni çözemedim, yardımc olabilir misiniz

Kopya_6_LI_HESAPLAR_-_Kopya.zip dosyasını indir - download

Kopya_6_LI_HESAPLAR_-_Kopya.zip dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[Biolightant]

Merhaba,
Sorunuz için teşekkür ederim.
Sayeniz de .Exists benzersiz değerleri yakalamayı öğrendim.

Kodlar çok hızlı çalışıyor, hiç bir şey yapmıyor gibi gözüküyor.
gözlem yapabilmek için isterseniz Application.ScreenUpdating = False silerek çalıştırın

Sub ANA_HESAP_SAYFALARINA_AYIR()
    Dim zaman As Double
    Dim v As Variant
    Dim hesap As Object
    Dim a As Long
    Dim k As Worksheet
    Dim sh As Worksheet
    Dim soru As VbMsgBoxResult
    Dim yeniSayfa As Worksheet
    
    ' Kullanıcıdan onay al
    soru = MsgBox("VARSA; veri sayfası dışındaki sayfaların TÜMÜ SİLİNECEK EMİN MİSİNİZ? ", vbYesNoCancel)
    If Not soru = vbYes Then Exit Sub
    
    ' Zamanı ölçmek için Timer başlat
    zaman = Timer
    
    ' Ekran güncellemelerini ve hesaplamayı devre dışı bırak
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Sayfa1'i seç
    Set k = Sheets("Sayfa1")
    
    ' Diğer sayfaları sil ( silerken soru sorma )
    Application.DisplayAlerts = False
        For Each sh In ThisWorkbook.Sheets
            If sh.Name <> k.Name Then sh.Delete
        Next sh
    Application.DisplayAlerts = True
    
    ' Veri aralığını bir diziye dönüştür
    v = k.Range("A2:L" & k.Cells(Rows.Count, 12).End(xlUp).Row).Value
    
    ' Dictionary ile benzersiz hesapları bul
    Set hesap = CreateObject("Scripting.Dictionary")
    For a = LBound(v, 1) To UBound(v, 1)
        ' 11. sütunun (L) ilk 3 karakteri numerikse VE aynı değer daha önce eklenmemişse
        If IsNumeric(Left(v(a, 11), 3)) And Not hesap.Exists(Left(v(a, 11), 3)) Then
            
            ' İlk 3 karakter benzersizse, değeri ekle
             hesap.Add Left(v(a, 11), 3), 1
            
            ' yeni sayfa ekle
            Set yeniSayfa = Sheets.Add(After:=Sheets(Sheets.Count))
            
            ' sayfanın ismi 11.sütün(L) nin değerinin ilk 3 karakteri olsun ( Exists sayesinde benzersiz değer)
            yeniSayfa.Name = Left(v(a, 11), 3)
            
            Worksheets("Sayfa1").Range("A1:L1").Copy
            Sheets(Left(v(a, 11), 3)).Select
            Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            ActiveSheet.Paste
            ActiveSheet.Range("A1").Select
            
            
        End If
    Next a
    
    Worksheets("Sayfa1").Select

    ' Uyarı ve hesaplama ayarlarını geri yükle
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

    ' İşlem süresini göster
    MsgBox "İşlem süresi: " & Round(Timer - zaman, 2) & " saniye", vbInformation

End Sub