verileri belirli şartlarla yanyana getirmek

[kakara]

merhaba ustadlarım sızlerden rıcam sayfa 1 de olan tabloda alt alta gelen verılerın sayfa 2 belırlı şartlarla yanyana getırmek detaylı açıklamaları ektekı dosyada yazdım şimdiden ilginiz için teşşekkur ederim.

 

[kakara]

sorun gunceldır ılgınız ıcın tesekkurler.

 

[vein03051976]

Merhaba

Biz bunun için özet tablo kullanıyoruz.

Dosyanız ektedir.

 

[kakara]

ustadım ılgınız ıcın tesekkur ederım ama dedıgım gıbı 10bın satır ve cok farklı bedenler olunca pivot işimi görmuyor ben ger barkodun uzerınde kendıne aıt olan bedenlerın yazılmasını ıstemıstım. yınede ılgınız ıcın tesekkurler

 

[kulomer46]

Değerli Arkadaşım

Dosyanız Hazır.

Rapor Sayfası her tıklandığında Sayfa1 Sayfası Rapor Sayfasına özetlenmektedir.

Sadece Bilgi Seri ve Bilgi Tekleme alanlarınızı yanlış anlamış olmayalım diye boş bıraktık.
Bilgi Seri ve Bilgi Tekleme alanlarında nasıl bir sonuç istediğinizide daha ayrıntılı yazarsanız İnşallah Bilgi Seri ve Bilgi Tekleme Alanları eklenmiş halde dosyanızı güncelleriz.

Selamlar...

 

[kulomer46]

Tekrar Merhaba

Yukardaki #5 numaralı mesaj ekindeki dosyanın daha gelişmiş hali ek 'tedir.

Selamlar...

 

[kakara]

@kulomer46 ustadım ılgınız ıcın tesekkur ederım adama yaklasık 10 bın satırlık bır calısma sızın guncelleme yaptıgınız calısma uzerınde denedım 10 dakıkadır excel yanıt vermıyor seklınde bekletıyor benı

 

[Ziynettin]

#1. iletide ekli dosyanızda kodu deneyiniz.

Sub test()
Dim s1 As Worksheet, s2 As Worksheet

Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

Set dc = CreateObject("scripting.dictionary")
Set dz = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
Set dv = CreateObject("scripting.dictionary")
Set dt = CreateObject("scripting.dictionary")
Set dk = CreateObject("scripting.dictionary")

Z = TimeValue(Now)
a = s1.Range("A1:S21").Value

For i = 2 To UBound(a)
    dv(a(i, 7)) = ""
    krt = a(i, 3) & "|" & a(i, 5)
    dc(krt) = i
    dt(krt) = dt(krt) + a(i, 8)
    ds(krt) = ds(krt) + 1
    If dk.exists(krt) Then
        If a(i, 8) < a(dk(krt), 8) Then
            dk(krt) = i
        End If
    Else
        dk(krt) = i
    End If
    krt1 = a(i, 3) & "|" & a(i, 5) & "|" & a(i, 7)
    dz(krt1) = dz(krt1) + a(i, 8)
Next i


sat = dc.Count + 1
sut = dv.Count + 8
ReDim c(1 To sat, 1 To sut)

say = 1
c(say, 1) = a(1, 3)
c(say, 2) = a(1, 5)
c(say, 3) = a(1, 6)

    For j = 0 To dv.Count - 1
        c(say, j + 4) = dv.keys()(j)
    Next j

p = dv.Count + 3
c(say, p + 1) = "Genel Toplam"
c(say, p + 2) = "Minimum"
c(say, p + 3) = "Beden Adet"
c(say, p + 4) = "Toplam"
c(say, p + 5) = "Tekleme"

For i = 0 To dc.Count - 1
    say = say + 1
    c(say, 1) = a(dc.items()(i), 3)
    c(say, 2) = a(dc.items()(i), 5)
    c(say, 3) = a(dc.items()(i), 6)
        For j = 1 To dv.Count
            krt = c(say, 1) & "|" & c(say, 2) & "|" & c(1, j + 3)
            c(say, j + 3) = dz(krt)
        Next j
    yy = c(say, 1) & "|" & c(say, 2)
    c(say, p + 1) = dt(yy)
    c(say, p + 2) = a(dk(yy), 8)
    c(say, p + 3) = ds(yy)
    c(say, p + 4) = c(say, p + 2) * c(say, p + 3)
    c(say, p + 5) = c(say, p + 1) - c(say, p + 4)
Next i
Application.ScreenUpdating = False
    s2.Cells.ClearContents
    s2.Cells.ClearFormats
    s2.[B1].Resize(say, sut) = c
    s2.[B1].Resize(say, sut).Borders.Color = rgbSilver
    s2.[B2].Resize(say - 1, sut).Font.Size = 9
    s2.[B1].Resize(say, sut).Interior.Color = 14348258
    s2.[B1].Resize(say, sut).HorizontalAlignment = xlCenter
    s2.[B1].Resize(say, sut).VerticalAlignment = xlCenter
    s2.[B1].Resize(, sut).Interior.Color = 15123099
Application.ScreenUpdating = True

MsgBox "İşlem tamam." & vbLf & vbLf & _
        "İşlem süreniz :  " & CDate(TimeValue(Now) - Z), vbInformation
End Sub

 

[kakara]

@Ziynettin ustadım ılgınız ıcın tesekkurler kodlar calısıyor ve 5 sanıye gıbı bır surede işlem tamamlandı

 

[Korhan Ayhan]

Alternatif;

10.000 adet benzersiz veri içeren tabloda 2 saniye gibi bir sonuç aldım. (İ5 8. Nesil işlemci ile)

Option Explicit

Sub Pivot_Table()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Pivot_Cache As PivotCaches, Pivot_Data As Range
    Dim Pivot_Table As PivotTables, Zaman As Double
    Dim Veri As Variant, X As Long, Y As Byte, Say As Long
    Dim Beden_Adet As Integer, Minimum As Variant
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S2.Cells.Delete
    
    Set Pivot_Data = S1.Range("A1").CurrentRegion
    
    If Pivot_Data.Rows.Count = 1 Then
        MsgBox "Sayfada işlem yapılacak veri bulunamadı!", vbCritical
        Exit Sub
    End If
    
    On Error Resume Next
    
    Set Pivot_Cache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=Pivot_Data). _
                      CreatePivotTable(TableDestination:=S2.Range("A1"), TableName:="Pivot_Table1")
    
    Set Pivot_Table = Pivot_Cache.CreatePivotTable(TableDestination:=S2.Range("A1"), TableName:="Pivot_Table1")
    
    On Error GoTo 0

    With S2.PivotTables("Pivot_Table1")
        .PivotFields("ITEM").Orientation = xlRowField
        .PivotFields("ITEM").Position = 1
        .PivotFields("ITEM").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
        .PivotFields("VARYANT").Orientation = xlRowField
        .PivotFields("VARYANT").Position = 2
        .PivotFields("MODEL TANIM").Orientation = xlRowField
        .PivotFields("MODEL TANIM").Position = 2
        .PivotFields("MODEL TANIM").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
        .AddDataField S2.PivotTables("Pivot_Table1").PivotFields("ADET"), "Sum of ADET", xlSum
        .PivotFields("SIZE").Orientation = xlColumnField
        .PivotFields("SIZE").Position = 1
        .RepeatAllLabels xlRepeatLabels
        .RowAxisLayout xlTabularRow
    End With
    
    S2.Range("A1").CurrentRegion.Offset(1).Copy
    S2.Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    S2.Cells(S2.Rows.Count, 1).End(3) = "Genel Toplam"
    S2.Cells(1, S2.Columns.Count).End(1) = "Genel Toplam"
    S2.Range("A1").Resize(1, S2.Cells(1, S2.Columns.Count).End(1).Column).Font.Bold = True
    S2.Range("A1").Resize(S2.Cells(S2.Rows.Count, 1).End(3).Row).Font.Bold = True
    S2.Cells(S2.Rows.Count, 1).End(3).Resize(1, S2.Cells(1, S2.Columns.Count).End(1).Column).Font.Bold = True
    S2.Cells(1, S2.Columns.Count).End(1).Resize(S2.Cells(S2.Rows.Count, 1).End(3).Row).Font.Bold = True
        
    Veri = S2.Range("A1").CurrentRegion.Value
    
    ReDim Liste(1 To UBound(Veri, 1) - 1, 1 To 4)

    For X = 2 To UBound(Veri, 1) - 1
        Minimum = Empty
        Beden_Adet = 0
        
        For Y = 4 To UBound(Veri, 2) - 1
            If Veri(X, Y) <> "" Then
                Beden_Adet = Beden_Adet + 1
                If Minimum = Empty Then
                    Minimum = Veri(X, Y)
                Else
                    Minimum = WorksheetFunction.Min(Minimum, Veri(X, Y))
                End If
            End If
        Next
        
        Say = Say + 1
        Liste(Say, 1) = Minimum
        Liste(Say, 2) = Beden_Adet
        Liste(Say, 3) = Minimum * Beden_Adet
        Liste(Say, 4) = Veri(X, UBound(Veri, 2)) - Liste(Say, 3)
    Next
    
    S2.Cells(1, S2.Columns.Count).End(1)(1, 2).Resize(1, 4) = Array("Minimum", "Beden Adet", "Toplam", "Tekleme")
    S2.Cells(2, UBound(Veri, 2) + 1).Resize(Say, 4) = Liste
    S2.Cells(1, UBound(Veri, 2) + 1).Resize(1, 4).Font.Bold = True
    
    S2.Select
    S2.Range("A1").Select
    
    S2.Columns.AutoFit
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Pivot_Data = Nothing
    Set Pivot_Cache = Nothing
    Set Pivot_Table = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00") & " Saniye"
End Sub

 

[kakara]

ilginiz için tesekkurler @Korhan Ayhan ustadım kod calısıyor ve dedıgınız gıbı hızlı