Daten-Konsolidierung, Kopieren / Array?

[Rabe]

Hallo,

ich habe eine Datei mit Tabellenblättern pro Jahr von 1998 bis heute, jeweils Spalte A bis AR und in Summe mehr als 23.500 Zeilen.


Nun will ich die alle auf einem Blatt zusammenkopieren. Das mache ich mit folgendem Makro-Teil:

Option Explicit

Sub Alle_Tabelle_Neu_erstellen()
  Dim loLetzte As Long
  Dim loZeile As Long
  Dim i As Long
  Dim j As Long
  Dim Kunde As String
  Dim Kundentyp As String
  Dim Ergebnis As Range
 
  'AutoFilter Alle-Tabelle ausschalten
  Worksheets("Alle").Select
  If ActiveSheet.AutoFilterMode Then Range("A:A").AutoFilter
 
  'Tabelle Neuberechnung auf Manuell schalten
  With Application
     .CalculateBeforeSave = True
     .Calculation = xlCalculationManual
  End With
 
  'Bildschirm akutalisieren ausschalten
  Application.ScreenUpdating = False
 
  'Bestehende Daten löschen
  Range("A3", ActiveSheet.Range("AW3").End(xlDown)).ClearContents
 
  For j = 1998 To year(Now)   'ab 2015: Zeile 14410
     Worksheets(CStr(j)).Select
     If ActiveSheet.AutoFilterMode Then Range("A:A").AutoFilter
     loLetzte = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row           ' letzte belegte in Spalte A (1)
     ActiveSheet.Range("A2:AR" & loLetzte).Copy
     
     With Worksheets("Alle")
        loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row           ' letzte belegte in Spalte A (1)
        loZeile = loLetzte + 1
       
        .Range("A" & loZeile).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=False
     End With
     Worksheets(CStr(j)).Select
     Range("A1").Select
     If Not ActiveSheet.AutoFilterMode Then Selection.AutoFilter
  Next j
'...

Um mir das ganze Rumgemache mit dem Autofilter zu ersparen, würde ich gerne die Gesamttabelle in eine intelligente Tabelle umwandeln.

Momentan wird alles gelöscht und wieder kopiert.
Wenn ich dann aber das Makro starte, werden zwar die belegten Zellen geleert, aber die zu kopierenden Zeilen werden von 23.500 bis 47.000 eingefügt.

1. Wie muß ich dieses Makro ändern, daß ich dann, wie seither in Zeile 3 (1. Datenzeile der intelligenten Tabelle) beginnend, die Daten erhalte.
   
2. Kann ich auch nur ab 2015 (Zeile 14.410) die Daten aus den Blättern hole und die älteren einfach stehen lasse.
   
3. Wie kann das Makro schneller gemacht werden, mit Array? Wie mache ich das?
   

[edit] jetzt fällt mir gerade Power Query ein, aber damit habe ich gar keine Erfahrung.

[Gast 123]

Hallo

ich habe mal versucht den Code etwas zu kürzen, konnte aber nicht prüfen ob es so klappt.
Ein Fehler ist warhscheinlich hinter With Worksheets("Alle").  Dort wird mit loLetzte kopiert statt mit loZeile. Die Variable loLetzte wird auch zweimal geladen, mit LastZell aus zwei verschiedenen Tabellen! Das ist sicher nicht richtig.  

Bei loZeile habe ich die Suche nach LastZell hinter den Kopiervorgang gesetzt, damit die naechsten Datensaetze unten angehangen werden können.  Der 1. Wert für loZeile kann für eine Intelligente Tabelle auf 3 festgelegt werden, für Kopie Start mit 3. Zeile.

Für Verbesserungen mit Array ist snb sicher der richtige Profi, damit kenne ich mich auch nicht aus!

mfg  Gast 123

Code:

Option Explicit

Sub Alle_Tabelle_Neu_erstellen()
 Dim loLetzte As Long
 Dim loZeile As Long
 Dim i As Long
 Dim j As Long
 Dim Kunde As String
 Dim Kundentyp As String
 Dim Ergebnis As Range
 
 'AutoFilter Alle-Tabelle ausschalten
 Worksheets("Alle").Select
 If ActiveSheet.AutoFilterMode Then Range("A:A").AutoFilter
 
 'Tabelle Neuberechnung auf Manuell schalten
 With Application
    .CalculateBeforeSave = True
    .Calculation = xlCalculationManual
 End With
 
 'Bildschirm akutalisieren ausschalten
 Application.ScreenUpdating = False
 
 'Bestehende Daten löschen
 Range("A3", Range("AW3").End(xlDown)).ClearContents
 loZeile = 3   '1.Zeile im Blatt Alle zum kopieren
 
 For j = 2015 To Year(Now)   'ab 2015: Zeile 14410
 With Worksheets(CStr(j))
    If .AutoFilterMode Then Range("A:A").AutoFilter
    ' letzte belegte in Spalte A (1)
    loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("A2:AR" & loLetzte).Copy
   
    With Worksheets("Alle")
       .Range("A" & loZeile).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
           Operation:=xlNone, SkipBlanks:=False, Transpose:=False
       ' letzte belegte in Spalte A (1)
       loZeile = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    End With
    Worksheets(CStr(j)).Select
    Range("A1").Select
    If Not .AutoFilterMode Then Selection.AutoFilter
 End With
 Next j
End Sub

[Rabe]

Hallo Peter,

danke für die Prüfung und Änderung des Codes. Ich habe meine Fehler behoben.

Ich habe es nun so gemacht:

Code:

Option Explicit

Sub Alle_Tabelle_Neu_erstellen()
   Dim loLetzte As Long
   Dim loZeile As Long
   Dim loZeileNeu As Long
   Dim i As Long
   Dim j As Long
   Dim Kunde As String
   Dim Kundentyp As String
   Dim Ergebnis As Range
  
   'AutoFilter Alle-Tabelle ausschalten
   Worksheets("Alle").Select
   Range("A2:AW2").Select
   If ActiveSheet.AutoFilterMode Then Selection.AutoFilter
  
   With Application
      .CalculateBeforeSave = True
      .Calculation = xlCalculationManual        'Tabelle Neuberechnung auf Manuell schalten
      .ScreenUpdating = False                   'Bildschirm akutalisieren ausschalten
   End With
  
   'Bestehende Daten löschen
   loZeileNeu = 14411   '1.Zeile im Blatt Alle zum einfügen, für 2015: Zeile 14411
   Range("A" & loZeileNeu, Range("AW" & loZeileNeu).End(xlDown)).ClearContents
   loZeile = loZeileNeu
  
   For j = 2015 To year(Now)
      With Worksheets(CStr(j))
         If .AutoFilterMode Then Range("A:A").AutoFilter
         loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row           ' letzte belegte in Spalte A (1)
         .Range("A2:AR" & loLetzte).Copy
      End With
      
      With Worksheets("Alle")
         .Range("A" & loZeile).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
             Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         loZeile = .Cells(Rows.Count, 1).End(xlUp).Row + 1        ' erste freie in Spalte A (1)
      End With
      
      'AutoFilter Jahr-Tabelle einschalten
      'hier wird komischerweise die Autofilterfunktion für einzelne Jahrestabellen nicht wieder gesetzt (2015 nicht, 2016 ja, 2017 nicht, 2018 ja)!
      Worksheets(CStr(j)).Select
      Range("A1:AR1").Select
      If Not ActiveSheet.AutoFilterMode Then Selection.AutoFilter
      Range("A2").Select
   Next j
   '...

Dieser Code ist auch schnell genug. Das war er vorher schon.
Leider funktioniert es mit der intelligenten Tabelle nicht, die Jahre ab 2016 werden dann trotzdem unter den seitherigen nun leeren Teil der int. Tabelle angehängt. Also habe ich sie wieder umgewandelt in einen Bereich.

Ich habe nun gemerkt, daß der darauf folgende Code-Teil das ist, was das Makro langsam macht:

Code:

'...
   'Berechnen der Quartale und Monate
   With Worksheets("Alle")
      loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row           ' letzte belegte in Spalte A (1)
      
      For i = loZeileNeu To loLetzte
         'Ermittle Kunde und Kundentyp
         Kunde = .Range("H" & i)
         Set Ergebnis = Worksheets("Listen3").Columns(1).Find(what:=Kunde, LookAt:=xlWhole)
         If Ergebnis Is Nothing Then
            Kundentyp = "n.d."
         Else
            Kundentyp = Worksheets("Listen3").Range("B" & Ergebnis.Row)    'Blatt Listen3
         End If
         .Range("AS" & i) = Kundentyp
        
         'Datum geliefert: Jahr/Monat eintragen
         If IsDate(.Range("T" & i)) Then .Range("AT" & i) = Format(.Range("T" & i), "yyyy") & "/" & Format(.Range("T" & i), "mm") Else .Range("AT" & i) = "n.d."
         'Datum geliefert: Jahr/Quartal eintragen
         If IsDate(.Range("T" & i)) Then .Range("AU" & i) = Format(.Range("T" & i), "yyyy") & "/" & (-Int(-Month(.Range("T" & i)) / 3)) Else .Range("AU" & i) = "n.d."
        
         'Suchhilfe
         .Range("AV" & i) = .Range("I" & i) & " " & .Range("J" & i) & " " & .Range("L" & i)
        
         'Suchhilfe Seriennummer
         If year(.Cells(i, 7)) < 2001 Then
            .Range("AW" & i) = "'" & Format(.Range("F" & i), "000") & Format(.Range("G" & i), "mm") & Right(.Range("A" & i), 1)
         Else
            .Range("AW" & i) = "'" & Format(.Range("F" & i), "0000") & Format(.Range("G" & i), "mm") & Format(.Range("G" & i), "yy")
         End If
      Next i
   End With
  
   'Wiedereinschalten der Autofilterfunktion
   Worksheets("Alle").Select
   Range("A2:AW2").Select
   If Not ActiveSheet.AutoFilterMode Then Selection.AutoFilter
   Range("A3").Select
  
   With Application
      .CalculateBeforeSave = True
      .Calculation = xlCalculationAutomatic     'Tabelle Neuberechnung auf AUTOMATISCH
      .ScreenUpdating = True                    'Bildschirm akutalisieren einschalten
   End With
  
End Sub

Kann das irgendwie schneller gemacht werden?

[schauan]

Hallo Ralf,

nur mal ein Tipp mit den intelligenten Tabellen.. In Deinem Code löschst Du die Zellinhalte, aber nicht die Zeilen. Dadurch bleibt die Tabelle in voller Größe und das End(xlup) bringt nicht das erwartete Ergebnis.
Du springst damit nur an das Ende der Intelligenz Wenn Du das Ende der Daten erwischen willst, musst Du nochmal springen.

Bei Deinem "langsamen" codeteil könntest Du schauen, ob Du die betroffenen Spalten in mehrere Array's nimmst, dann in den Arrays arbeitest und die Ergebnisse in die Zellen zurückspielst.
Alternativ könntest Du eventuell auch in die zu berechnenden Zellinhalte temporär Formeln eintragen, rechnen, und dann die Formelergebnisse durch die Werte ersetzen.

[Rabe]

Hi André,

ja, so mit dem Löschen der intelligenten Zeilen hat es nun natürlich geklappt.

Es sind momentan 10.000 Zeilen, die mit den beerechneten Inhalten versehen werden sollen.
Meinst Du, das wird schneller, wenn ich zuerst die Formeln eintrage und dann die kopierten Werte einfüge, als wenn ich gleich im Makro die Inhalte einfüge?

Das mit dem Aufnehmen in Arrays und dort Daten zusammensetzen habe ich noch nie gemacht.

[snb]

Code:

Sub M_snb()
  if [not(isref(Total!a1))] then sheets.add().name="Total"

  for each it in sheets
     sn=it.cells(1).currentregion
     if it.name<>"Total" then sheets("Total").cells(rows.count,1).end(xlup).offset(1).resize(ubound(sn),ubound(sn,2))=sn
  next
End Sub

oder

Code:

Sub M_snb()
  c00 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 8.0"""
  if [not(isref(Total!a1))] then sheets.add().name="Total"    

  For Each it In Sheets
    With CreateObject("ADODB.Recordset")
      .Open "SELECT * FROM `" & it.Name & "$`", c00
      If it.Name <> "Total" Then Sheets("Total").Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset .DataSource
    End With
  Next
End Sub

[schauan]

Hallo Ralf,

ob das mit den Formeln und Werte einfügen schneller geht, muss man im Einzelfall schauen. Auf jeden Fall kannst Du schon mal mit einer Codezeile 10.000 Formeln und mehr eintragen, dann wird gerechnet, und dann kopiert und die Werte eingefügt. Im Code gehst Du ie Zellen ja alle einzeln durch, übernimmst Inhalte, rechnest was, schreibst einzeln zurück ...

hier mal ein Ansatz für eine Arraylösung für den ersten Teil Deiner Bearbeitung. Statt der Spalten A, B usw. musst Du natürlich Deine nehmen. Wenn Deine Tabelle gefüllt ist, kann man natürlich auch mir den Objekten eines ListObjects arbeiten und braucht z.B. nicht unbedingt die letzte Zeile zu ermitteln.

Die Übernahme von arrB nach arrAS führt so programmiert übrigens zu einem Fehler, wenn es sich dabei um eine leere Zelle handelte. Wenn so was vorkommen kann, müsste man gegensteuern.

Code:

Sub testArrays()
'Variablendeklarationen
'Arrays
Dim arrKundenTyp, arrB, arrKunde, arrAS
'Integer
Dim iCnt%, iRow%
'Spalten einzeln in Arrays ubernehmen, Laenge anhand Spalte A
arrKundenTyp = WorksheetFunction.Transpose(Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row))
arrB = WorksheetFunction.Transpose(Range("B1:B" & Cells(Rows.Count, 1).End(xlUp).Row))
arrKunde = WorksheetFunction.Transpose(Range("H1:H" & Cells(Rows.Count, 1).End(xlUp).Row))
'Array fuer Ergebnisse redimensionieren
ReDim arrAS(1 To UBound(arrKunde))
'Schleife ueber alle Arayelemente
For iCnt = 1 To UBound(arrKunde)
 'nach Kunde suchen
 iRow = Application.Match(arrKunde(iCnt), arrKundenTyp, 0)
 'Wenn kein Fehler zurueckgegeben wurde, dann
 '( es wurde einer gefunden )
 If Not IsError(iRow) Then
   'Zeilennummer uebernehmen
   arrAS(iCnt) = arrB(iRow)
'ansonsten Wenn ein Fehler zurueckgegeben wurde, dann
 Else
   'n.d. eintragen
   arrAS(iCnt) = "n.d."
 'Ende Wenn kein Fehler zurueckgegeben wurde, dann
 End If
'Ende Schleife ueber alle Arayelemente
Next
'Ergebnis in SPalte AS eintragen
Range("AS1:AS" & UBound(arrKunde)) = WorksheetFunction.Transpose(arrAS)
End Sub

[Wastl]

Hi,

grundsätzlich braucht Excel etwas Zeit um etwas in die Tabelle zu schreiben.
Da bei ist der Unterschied marginal, ob er eine Zeile schreibt oder ob er 1000x1000 Zellen gleichzeitig schreibt.
Ganz schlimm wird es, wenn er bei 1000x1000 Zellen eine Zelle nach der anderen schreibt.

Darum ist die Idee geschwindigkeitsmäßig pricklend, alles an Berechnungen im Arbeitsspeicher zu machen und das Ergebns erst, wenn fertig, zurück in die Tabelle zu schreiben.
Formatieren, im Arbeitspeicher geht zwar nicht - sieht ja auch keiner - , sollte danach erledigt werden, bzw bevor die Daten geschrieben werden.

[snb]

Code:

Sub M_snb()
  if [not(isref(Total!a1))] then sheets.add().name="Total"

  for each it in sheets
     sn=it.cells(1).currentregion.resize(,52)
     if it.name<>"Total" then
        for j=1 to ubound(sn)
           sn(j,46)="n.d."
           if isdate(sn(j,20)) then
               sn(j,46)=format(sn(j,20),"yyyy/mm")
               sn(j,47)=format(sn(j,20),"yyyy q")
               sn(j,48)="......"
           end if
         next
         sheets("Total").cells(rows.count,1).end(xlup).offset(1).resize(ubound(sn),ubound(sn,2))=sn
     end if
  next
End Sub

NB. Ich verstehe nicht warum du keine Beispieldatei hochladest.

[Rabe]

Hi,

Ich verstehe nicht warum du keine Beispieldatei hochladest.

ich auch nicht.
Ich werde versuchen, heute eine anzufertigen.
Falls ich es heute zeitlich nicht schaffe, komme ich frühestens nächsten Donnerstag dazu.