Ana hesaplara ayırmada sorun

1

1903emre34@gmail.com

Altın Üye
Katılım
29 Mayıs 2016
Mesajlar
906
Excel Vers. ve Dili
Microsoft Excel 2013 Türkçe
Altın Üyelik Bitiş Tarihi
06-06-2027
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 www.dosya.tc
 
Biolightant

Biolightant

Katılım
6 Mart 2024
Mesajlar
103
Excel Vers. ve Dili
Excel 2010 TR & Excel 2016 TR
Merhaba,
Sorunuz için teşekkür ederim.
Sayeniz de .Exists benzersiz değerleri yakalamayı öğrendim.

Kodlarınız diğer bilgisayarda çalıştı
emin olmamakla birlikte Application.Transpose problem oluyor gibi.

Alternatif kodlar..

C++: 
Sub ANA_HESAP_SAYFALARINA_AYIR()
    Dim zaman As Double
    Dim v As Variant
    Dim snc() As Variant
    Dim hesap As Object
    Dim a As Long, va As Long, u As Long
    Dim say As Long, topl As Long
    Dim sh As Worksheet
    Dim k As Worksheet
    Dim h As Variant
    Dim soru As VbMsgBoxResult
    Dim syf As Long
    Dim shf As Worksheet
    
    ' Kullanıcıya onay sorusu
    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çümüne başla
    zaman = Timer
    
    ' Sonuç dizisini yeniden boyutlandır
    ReDim snc(1 To 12, 1 To 1)
    
    ' Sayfa1'i seç
    Set k = Sheets("Sayfa1")
    
    ' Ekran güncellemelerini kapat
    Application.ScreenUpdating = False
    
    ' Diğer sayfaları sil ( uyarıları kapat )
    Application.DisplayAlerts = False
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> k.Name Then sh.Delete
    Next
    Application.DisplayAlerts = True
    
    ' Verileri diziye al
    v = k.Range("A2:L" & k.Cells(Rows.Count, 12).End(xlUp).Row).Value2
    
    ' Benzersiz hesapları bulmak için dictionary kullan
    Set hesap = CreateObject("Scripting.Dictionary")
    For a = LBound(v) To UBound(v)
        If IsNumeric(Left(v(a, 11), 3)) And Not hesap.Exists(Left(v(a, 11), 3)) Then
            hesap.Add Left(v(a, 11), 3), 1
        End If
    Next
    
    ' Her bir benzersiz hesap için
    For Each h In hesap.Keys
        ' Yeni sayfa ekle ve ismini ayarla
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = h
        
        ' Verileri filtrele ve diziye al
        For va = 1 To UBound(v)
            If Left(v(va, 11), 3) = h Then
                say = say + 1
                ReDim Preserve snc(1 To 12, 1 To say)
                For u = 1 To 12
                    snc(u, say) = v(va, u)
                    If u = 1 Then snc(u, say) = CLng(snc(u, say)) ' Tarih formatı ayarlama
                Next u
            End If
        Next va
        
        ' Sayfaya verileri satır satır yaz
        With Sheets(h)
            .Range("A1:L1").Value = k.Range("A1:L1").Value
            .Columns(1).NumberFormat = "dd/mm/yyyy;@"
                      
            ' Satır satır veriyi yazdırma
            For va = 1 To say
                For u = 1 To 12
                    .Cells(va + 1, u).Value = snc(u, va)
                Next u
            Next va
            
            .Columns.AutoFit
        End With
        
        ' Diziyi sıfırla ve sayaçları sıfırla
        Erase snc
        ReDim snc(1 To 12, 1 To 1)
        topl = topl + say
        say = 0
    Next h
    
    ' Sayfa1'e geri dön
    k.Activate
    
    ' Sayfaları alfabetik olarak sırala
    If ThisWorkbook.Sheets.Count > 2 Then
        For Each shf In ThisWorkbook.Sheets
            For syf = 3 To ThisWorkbook.Sheets.Count
                If Sheets(syf - 1).Name > Sheets(syf).Name Then
                    Sheets(syf - 1).Move After:=Sheets(syf)
                End If
            Next syf
        Next shf
    End If
    
    ' Hesap nesnesini temizle
    Set hesap = Nothing
    
    ' Ekran güncellemeleri aç
    Application.ScreenUpdating = True
    
    ' Zamanı göster
    MsgBox "İşlem süresi: " & Round(Timer - zaman, 2) & " saniye", vbInformation
End Sub
 
Son düzenleme:
Biolightant

Biolightant

Katılım
6 Mart 2024
Mesajlar
103
Excel Vers. ve Dili
Excel 2010 TR & Excel 2016 TR
Hızlı Alternatif kodlar
Veriler Filtre ile alınarak hızlandırıldı.

C++: 
Option Explicit

Sub ANA_HESAP_SAYFALARINA_AYIR()
    Dim zaman As Double
    Dim v As Variant
    Dim hesap As Object
    Dim a As Long
    Dim sh As Worksheet
    Dim k As Worksheet
    Dim soru As VbMsgBoxResult
    Dim hesapVeriler As Object
    Dim Key As Variant

    ' Kullanıcıya onay sorusu
    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çümüne başla
    zaman = Timer

    ' Sayfa1'i seç
    Set k = Sheets("Sayfa1")

    ' Ekran güncellemelerini kapat
    Application.ScreenUpdating = False

    ' Diğer sayfaları sil
    Application.DisplayAlerts = False
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> k.Name Then sh.Delete
    Next
    Application.DisplayAlerts = True

    ' Benzersiz hesapları bulmak için dictionary kullan
    Set hesap = CreateObject("Scripting.Dictionary")
    v = k.Range("A1:L" & k.Cells(Rows.Count, 1).End(xlUp).Row).Value2 ' Verileri al

    ' Benzersiz hesapları bul
    For a = LBound(v) To UBound(v)
        If IsNumeric(Left(v(a, 11), 3)) And Not hesap.Exists(Left(v(a, 11), 3)) Then
            hesap.Add Left(v(a, 11), 3), 1
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = Left(v(a, 11), 3)
        End If
    Next

    ' Sayfa1 hariç tüm sayfa sayısı kadar döngü
    Set hesapVeriler = CreateObject("Scripting.Dictionary")

    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> k.Name Then
            ' Verileri almak için sayfanın son satırını belirle
            v = k.Range("A1:L" & k.Cells(Rows.Count, 1).End(xlUp).Row).Value ' Sayfadaki verileri al

            ' İlk 3 rakamı sayfa ismiyle aynıysa hesapVeriler'e ekle
            For a = LBound(v) To UBound(v)
                If IsNumeric(Left(v(a, 11), 3)) Then
                    If Left(v(a, 11), 3) = Left(sh.Name, 3) And Not hesapVeriler.Exists(v(a, 11)) Then
                        hesapVeriler.Add v(a, 11), 1
                    End If
                End If
            Next a

            ' Eğer hesapVeriler boş değilse filtre uygulayın
            If hesapVeriler.Count > 0 Then

                ' HesapVeriler içindeki anahtarları diziye aktar
                Dim hesapDizi() As String
                ReDim hesapDizi(1 To hesapVeriler.Count)

                Dim i As Integer
                i = 1

                For Each Key In hesapVeriler.Keys
                    hesapDizi(i) = Key
                    i = i + 1
                Next Key

                ' Filtre uygula
                k.Range("A1:L" & k.Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=11, Criteria1:=hesapDizi, Operator:=xlFilterValues

                ' Filtrelenmiş verileri kopyala ve ilgili sayfaya yapıştır
                k.Range("A1:L" & k.Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=sh.Range("A1")

                ' Sütunların genişliğini otomatik yap
                sh.Columns.AutoFit

                ' Filtreyi temizle
                k.AutoFilterMode = False
            End If

            ' Her yeni sayfaya geçişte hesapVeriler'i temizle
            hesapVeriler.RemoveAll
        End If
    Next sh

    ' Sayfa isimlerini ve son satırları yaz
    Call SayfaSIRALA

    ' Sayfa1'e geri dön
    k.Activate
    
    ' Ekran güncellemelerini aç
    Application.ScreenUpdating = True

    ' Zamanı göster
    MsgBox "İşlem süresi: " & Round(Timer - zaman, 2) & " saniye", vbInformation
    
    ' TOPLAM VERİ KONTROL TEST ALANI
    ' Sayfa isimlerini ve son satırları yaz
    ' Tüm Sayfalarda ki L en son satırları toplamı ( ilk satırları hariç ( -sayfasayısı ) )
    ' Sayfa1 L sütünü sonsatır (il satır hariç ( -1 ))
    ' ikisininde aynı olması gerekli
    Call VeriKontrolTest

End Sub

Private Sub SayfaSIRALA()
    Dim i As Long
    Dim j As Long
    Dim sheetCount As Long

    sheetCount = ThisWorkbook.Sheets.Count

    ' Sayfa1' dışındaki sayfaları sıralamak için
    If sheetCount > 2 Then
        ' Sayfa1'in ilk sayfa olduğundan emin olun
        Dim sayfa1Index As Long
        sayfa1Index = 1 ' Sayfa1 her zaman ilk sayfa

        ' Bubble Sort
        For i = 2 To sheetCount - 1 ' 2. sayfadan itibaren başla
            For j = 2 To sheetCount - i
                ' Sayfa isimlerini karşılaştır ve gerekirse yer değiştir
                If Sheets(j).Name > Sheets(j + 1).Name Then
                    Sheets(j).Move After:=Sheets(j + 1)
                End If
            Next j
        Next i
    End If
End Sub

Private Sub VeriKontrolTest()
    Dim ws As Worksheet
    Dim sayfaIsmi As String
    Dim j As Integer

    ' Q ve R ve S sütunları Tümünü Temizle
    Sheets("Sayfa1").Columns("Q:S").Clear

    j = 0 ' Q sütunundaki ilk hücre için sayaç
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Sayfa1" Then ' Sayfa1 hariç tüm sayfa isimlerini yaz
            Sheets("Sayfa1").Range("Q" & j + 1).Value = ws.Name ' Q2, Q3, ... yaz
            Sheets("Sayfa1").Range("R" & j + 1).Value = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row
            j = j + 1 ' Sayaç artır
        End If
    Next ws
    
    Sheets("Sayfa1").Range("R" & j + 1).Formula = "=SUM(R1:R" & j & ")-" & j
    Sheets("Sayfa1").Range("S" & j + 1).Value = "Tüm Sayfaların L Sütunu Veri Toplamı"
    
    Sheets("Sayfa1").Range("R" & j + 2).Formula = "=ROWS(L1:L" & Sheets("Sayfa1").Cells(Rows.Count, 1).End(xlUp).Row & ")-1"
    Sheets("Sayfa1").Range("S" & j + 2).Value = "Sayfa1 L Sütunu Veri Toplamı"
    
    Sheets("Sayfa1").Range("S" & j + 3).Value = "Sütun Başlıkları ( L1 ler ) hariç olarak"

End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst