Sekmeli bir pivot oluşturmak için VBA'yı kullanma

Question

Bazı verileri özetlemekle görevlendirilmişim. Şu anda VBA'da oluşturulmuş bir pivotdan çok memnunum ve bunu başka bir sisteme yüklenen bir çalışma sayfasına kopyalar. Kullanıcılarımızın bazı dosyaları uzunluk (450k + satırlar 2013 32bit excel) ve karmaşıklık pivot işlemi hata kodu noktasında büyüyor. Ben aynı çıktıyı üretmek için bir betik sözlükleri kullanmak istiyorum ama bir örnek bulup son birkaç gün boyunca onunla oynamaktan sonra biraz yardıma ihtiyacım var. Kodun başlığında, bir veri örneği ve ihtiyacım olan çıktıya göre temelde bir tablo pivotu olan çıktılarım var. Gerçek örnek biraz daha karmaşık ama ben bir kez gördüğümde bunu çözebilirim. Bunun çalışma sayfasına nasıl aktığını ve aşağıdaki yöntemleri birleştirerek kendimi eğitmek için bir kaynak bulmanın zor bir zamanına sahip olduğumda bir şeyleri kaçırıyorum. Teşekkürler (sözlüğe)

Sub test() 

'DATA: 
'2005-00000 may 100 
'2005-00000 may 100 
'2005-00000 may 100 
'2005-00000 jun 100 
'2005-00000 jun 100 
'2005-99999 feb 100 
'2005-99999 feb 100 
'2005-99999 Nov 100 
'2005-22222 apr 100 
'2005-22222 apr 100 

'Output with Code Below 
'   may june feb Nov apr 
'2005-00000 300 200 
'2005-99999    200 100 
'2005-22222      200 


'Desired Output 
'2005-00000 may 300 
'2005-00000 jun 200 
'2005-99999 feb 200 
'2005-99999 Nov 100 
'2005-22222 apr 200 

Dim strtest As String 
Dim a, b(), i As Long, n As Long, t As Long 
Dim dict1 As Object, dic2 As Object 
Set dict1 = CreateObject("Scripting.Dictionary") 
dict1.CompareMode = vbTextCompare 
Set dict2 = CreateObject("Scripting.Dictionary") 
dict2.CompareMode = vbTextCompare 
With Range("a1").CurrentRegion.Resize(, 3) 

    a = .Value 
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1)) 
    b(1, 1) = Name: n = 1: t = 1 
    For i = 1 To UBound(a, 1) 
     If Not dict1.Exists(a(i, 1)) Then 
      n = n + 1: b(n, 1) = a(i, 1) 
      dict1.Add a(i, 1), n 
     End If 
     If Not dict2.Exists(a(i, 2)) Then 
      t = t + 1: b(1, t) = a(i, 2) 
      dict2.Add a(i, 2), t 
     End If 
     b(dict1(a(i, 1)), dict2(a(i, 2))) = b(dict1(a(i, 1)), dict2(a(i, 2))) + a(i, 3) 


    Next 
    With .Resize(1, 1).Offset(, .Columns.Count + 1) 
     .CurrentRegion.ClearContents 
     .Resize(n, t).Value = b 
    End With 
End With 
Set dict1 = Nothing: Set dict2 = Nothing 
End Sub 

Answer 1

alternatif çözüm

Option Explicit 

Sub test2() 

With ActiveSheet.Range("A1").CurrentRegion.Offset(, 3).Resize(, 1) 
    .FormulaR1C1 = "=concatenate(RC[-3], ""§§"", RC[-2])" 
    .Value = .Value 
    .Copy .Offset(, 1) 
    .Offset(, 1).RemoveDuplicates Columns:=Array(1), Header:=xlNo 
    .Offset(, 1).TextToColumns Destination:=.Offset(, 2), DataType:=xlDelimited, Other:=True, OtherChar:="§§" 
    .Offset(, 4).Resize(.Offset(, 1).SpecialCells(xlCellTypeConstants).Rows.Count).FormulaR1C1 = "=SUMIFS(C3,C1,RC[-2],C2,RC[-1])" 
    .Resize(, 2).ClearContents 
End With 

End Sub 

satır bir sürü olmalı ve çok zaman alıyor, sen With... bir ve bir önce Application.ScreenUpdating = False deyimi eklemek isteyebilirsiniz Application.ScreenUpdating = True ifade End With bir