Soru Gruplandırılmış ürün-fiyat listesi hazırlama

[netzone]

Merhabalar,

Mağazamızda bulunan ürünlerin takibi için kullanmış olduğumuz ticari programa erişim sağlayamayan arkadaşlarımız için sunumlarında yanlış fiyat vermemeleri ve arada bakmak için kullanacakları bir liste hazırlamaya karar verdik, ürün gruplarında erişimi hızlandırmak için ara ara değişiklikler yapıyoruz, Yaptığımız listeyi her defasında tekrar tekrar oluşturuyoruz.

Özetle yapılmak istenilen:
KIRPILMIS isimli sayfanın A:K sütun aralığındaki verileri K sütununda yer alan Grup adına göre GRUP Sayfasında Grup adı başlığı altında listeleyip grup aralarında 1 boş satır bırakması ve bu grupları kendi içinde ürün adına göre A>Z sıralaması işlemini makro ile yapmak istiyoruz.

Yardımınız için şimdiden teşekkür ederim.

 

[Merhum İdris SERDAR]

.

Dosyanız, Table ve Pivot Table'den yararlanarak yapılmıştır.


.

 

[Korhan Ayhan]

Bende ADO ile örnek hazırlamıştım.

Alternatif olsun.

Option Explicit

Sub Analiz()
    Dim S1 As Worksheet, S2 As Worksheet, Baglanti As Object
    Dim Kayit_Seti As Object, Sorgu As String, Veri_Seti As Object
    Dim Urun_Grubu As Variant, Satir As Long, Baslik As Variant
    Dim Sutun As Byte, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("KIRPILMIS")
    Set S2 = Sheets("GRUP")
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.RecordSet")
    Set Veri_Seti = CreateObject("AdoDb.RecordSet")
    
    S2.Cells.Delete
    Satir = 3
    Sutun = 1

    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""

    Sorgu = "Select [Ürün Grubu] From [" & S1.Name & "$] Where [Ürün Grubu] <> '' Group By [Ürün Grubu]"
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
    
    If Kayit_Seti.RecordCount > 0 Then
        S2.Cells(1, 11) = Now()
        S2.Cells(1, 11).Font.Bold = True
        
        For Each Urun_Grubu In Kayit_Seti.GetRows
            Sorgu = "Select * From [" & S1.Name & "$] Where [Ürün Grubu] = '" & Urun_Grubu & "' Order By [Ürünün Adı] Asc"
            Veri_Seti.Open Sorgu, Baglanti, 1, 1
            If Veri_Seti.RecordCount > 0 Then
                Say = Veri_Seti.RecordCount
                With S2.Cells(Satir - 1, 1)
                    .Font.Bold = True
                    .Interior.Color = 14277081
                    .Value = Urun_Grubu
                    .Resize(, 11).MergeCells = True
                    .HorizontalAlignment = xlCenter
                End With
                
                For Each Baslik In Veri_Seti.Fields
                    S2.Cells(Satir, Sutun) = Baslik.Name
                    Sutun = Sutun + 1
                Next
                
                S2.Range("A" & Satir & ":K" & Satir).Font.Bold = True
                S2.Cells(Satir + 1, 1).End(3)(2, 1).CopyFromRecordset Veri_Seti
                Satir = Satir + Say + 4
                Sutun = 1
            End If
            If Veri_Seti.State <> 0 Then Veri_Seti.Close
        Next
    End If

    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close
    
    S2.Range("A:K").ColumnWidth = 255
    S2.Rows.AutoFit
    S2.Columns.AutoFit
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
    Set Veri_Seti = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[netzone]

Merhaba,

Her ikinize de ayrı ayrı ilgi ve çözüm önerileriniz için teşekkür ederim.

İdris Bey, vermiş olduğunuz çözüme göre gerçek dosyamıza uyarladık. Sonuç olarak yapmak istediğimiz tabloyu *hızlı oluşturmamıza katkı sağladı.

Korhan Bey, referanslarım ekranda olduğu gibi aktif olmasına karşın sonuç aşağıdaki şekilde aldım. Aktif etmem gereken başka bir referans mı bulunuyor? yada uyarlamada mı yanlışlık yaptım bilemedim. Sorun nerede olabilir?

Teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Kod içinde kullandığım nesneleri Create ederek tanımladığım için herhangi bir referans seçmenize gerek yok.

Ben ilk mesajınızda ki eklediğiniz dosyada olumlu sonuç aldım. Asıl dosyanızda ki durumu bilemiyorum.

Foruma ekleme şansınız varsa hataya sebep olan durumu inceleyebiliriz.

 

[Korhan Ayhan]

Siz KIRPILMIS sayfanıza verileri fonksiyonla aldırmışsınız ve bu detay bilgiyi paylaşmamışsınız. Bu durumda hatalar oluşması gayet doğaldır.

#3 nolu mesajımda ki kodu revize ettim. Tekrar deneyiniz.

 

[Korhan Ayhan]

Alternatif olarak aşağıdaki kod ise Dictionary yöntemi kullanılmıştır.

Hız olarak biraz daha avantajlıdır.

Option Explicit

Sub Analiz()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Urun_Grubu As Variant
    Dim Veri As Variant, Son As Long, Satir As Long, Kayit_Sayisi As Long, Say As Long
    Dim Alan_1 As Range, Alan_2 As Range, X As Long, Y As Long, Z As Byte, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("KIRPILMIS")
    Set S2 = Sheets("GRUP")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    S2.Cells.Delete
    Satir = 3

    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
    
    S1.Cells(1, 27) = "Sıra No"
    
    With S1.Range("AA2")
        .Value = 1
        .AutoFill Destination:=S1.Range("AA2:AA" & Son), Type:=xlFillSeries
    End With
    
    S1.Range("A2:AA" & Son).Sort S1.Range("K2"), xlAscending, S1.Range("B2"), , xlAscending
    
    Veri = S1.Range("A1:K" & Son).Value
    
    S1.Range("A2:AA" & Son).Sort S1.Range("AA2"), xlAscending
    S1.Range("AA:AA").Clear
    
    With Dizi
        For X = LBound(Veri) + 1 To UBound(Veri)
            If Veri(X, 11) <> "" Then .Item(Veri(X, 11)) = 1
        Next
    End With
    
    Urun_Grubu = Dizi.Keys
    
    Kayit_Sayisi = Son + Dizi.Count * 2 * 2 - 2
    
    ReDim Liste(1 To Kayit_Sayisi, 1 To 11)
    
    Say = 1
    
    For X = LBound(Urun_Grubu) To UBound(Urun_Grubu)
        If Say = 1 Then Liste(Say, 11) = Now
        Liste(Say + 1, 1) = Urun_Grubu(X)
        If Alan_1 Is Nothing Then
            Set Alan_1 = S2.Cells(Say + 1, 1).Resize(, 11)
            Set Alan_2 = S2.Cells(Say + 2, 1).Resize(, 11)
        Else
            Set Alan_1 = Union(Alan_1, S2.Cells(Say + 1, 1).Resize(, 11))
            Set Alan_2 = Union(Alan_2, S2.Cells(Say + 2, 1).Resize(, 11))
        End If
        
        Say = Say + 2
        
        For Y = LBound(Veri) To UBound(Veri)
            If Y = 1 Then
                For Z = 1 To 11
                    Liste(Say, Z) = Veri(Y, Z)
                Next
            Else
                If Veri(Y, 11) = Urun_Grubu(X) Then
                    Say = Say + 1
                    For Z = 1 To 11
                        If Z = 1 Then
                            Liste(Say, Z) = CStr(Veri(Y, Z))
                        Else
                            Liste(Say, Z) = Veri(Y, Z)
                        End If
                    Next
                End If
            End If
        Next
        Say = Say + 2
    Next
    
    S2.Range("A:A").NumberFormat = "@"
    S2.Range("A1").Resize(Say - 2, 11) = Liste
    
    If Not Alan_1 Is Nothing And Not Alan_2 Is Nothing Then
        With Alan_1
            .MergeCells = True
            .Font.Bold = True
            .Interior.Color = 14277081
            .HorizontalAlignment = xlCenter
        End With
    
        With Alan_2
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
    End If
    
    S2.Range("A:K").ColumnWidth = 255
    S2.Rows.AutoFit
    S2.Columns.AutoFit
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[netzone]

Siz KIRPILMIS sayfanıza verileri fonksiyonla aldırmışsınız ve bu detay bilgiyi paylaşmamışsınız. Bu durumda hatalar oluşması gayet doğaldır.

#3 nolu mesajımda ki kodu revize ettim. Tekrar deneyiniz.

Teşekkürler Korhan Bey, Söz konusu fonksiyon kullanmış olduğum sayfayı değerlere çevirerek kullandığım için belirtmemiştim. Size gönderdiğim dosyada fonksiyon olarak kalmış sanırım. Tutarsızlık oluştuğu için kusuruma bakmayın, Her iki türde işimi gördü. Sağolun, iyi çalışmalar.

 

[mukoli]

yanlış