Microsoft Excel

Herbers Excel/VBA-Archiv

Code für die personl.xls | Herbers Excel-Forum


Betrifft: Code für die personl.xls von: WalterK
Geschrieben am: 20.01.2012 09:11:40

Hallo,

der folgende Code von Tino funktioniert wenn ich ihn in der Tabelle starte, wenn ich ihn in der personl.xls speichere und von dort starte wird als Fehler die Zeile

NewWS.Cells(3, n).Resize(myDic(n).Count) = .Transpose(myDic(n).items)

markiert.

Mit diesem Code summiere ich die Spalten 4 bis 17 wenn der ID (das sind die Spalten 1 bis 3) identisch ist.

Option Explicit

Sub Zusammenfassen()
Dim ArrayData(), myDic(1 To 50)
Dim n&, nn&, nnn&
Dim strID$
Dim NewWS As Worksheet

Set NewWS = ThisWorkbook.ActiveSheet

With NewWS 'Vorher evtl. Tabelle anpassen
    ArrayData = .Range("A3", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 50)
End With

For n = 1 To 50
    Set myDic(n) = CreateObject("Scripting.Dictionary")
Next n

For n = 1 To UBound(ArrayData)
    If ArrayData(n, 4) <> 0 Then 'überspringen wenn Summe 0
            strID = ArrayData(n, 1) & ArrayData(n, 2) & ArrayData(n, 3)
            If Not myDic(1).exists(strID) Then '1. ID
                For nnn = 18 To 50
                    myDic(nnn)(strID) = ArrayData(n, nnn)
                Next nnn
            End If
            For nnn = 1 To 3 'Name; Nr; Art
                myDic(nnn)(strID) = ArrayData(n, nnn)
            Next nnn
            
'            myDic(4)(strID) = "=SUM(RC5:RC17)" 'Summe
            
            For nnn = 4 To 17 'Monate Jan bis Dez
                myDic(nnn)(strID) = myDic(nnn)(strID) + ArrayData(n, nnn)
                If myDic(nnn)(strID) = 0 Then myDic(nnn)(strID) = Empty
            Next nnn
    End If
Next n

Erase ArrayData

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    With NewWS
        .EnableCalculation = False
        .Range(.Cells(3, 1), .Cells(.Rows.Count, 1)).Resize(, 50).ClearContents
    End With
    For n = 1 To 3 'Name; Nr; Art
        NewWS.Cells(3, n).Resize(myDic(n).Count) = .Transpose(myDic(n).items)
    Next n
    
'    .Cells(3, 4).Resize(myDic(4).Count).FormulaR1C1 = .Transpose(myDic(4).items) 'Summe
    
    For n = 4 To 50 'Monate Jan bis Dez und Sonst...
        NewWS.Cells(3, n).Resize(myDic(n).Count) = .Transpose(myDic(n).items)
    Next n
    
    NewWS.Cells(1, 1).Resize(, 50).EntireColumn.AutoFit 'auto optimale Spaltenbreite
    
    NewWS.EnableCalculation = True
    
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub
Danke für die Hilfe und Servus, Walter

  

Betrifft: AW: Code für die personl.xls von: Josef Ehrensberger
Geschrieben am: 20.01.2012 09:19:33


Hallo Walter,

ändere mal
Set NewWS = ThisWorkbook.ActiveSheet

in
Set NewWS = ActiveSheet



« Gruß Sepp »



  

Betrifft: Passt! Besten Dank Sepp! Servus, Walter von: WalterK
Geschrieben am: 20.01.2012 09:29:12




  

Betrifft: Das ist genau die Situation, die ich meine, ... von: Luc:-?
Geschrieben am: 20.01.2012 09:55:16

…wenn ich die übermäßige Strapazierung von ThisWorkbook kritisiere, denn das ist mitnichten zu ActiveWorkbook synonym wie manche zu glauben scheinen. Wdn die PgmCodes ausgelagert wie hier, passiert das. Dabei ist das doch ganz einfach zu verstehen → man muss es nur ins Deutsche übersetzen!
Gruß Luc :-?


Beiträge aus den Excel-Beispielen zum Thema "Code für die personl.xls"