Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Optimierung Makro Tabellenaktualisierung über 2 Arbeitsmappe
zurück: einzelne Zellenwerte aus einer Matrix auslesen weiter: Verteilerliste erstellen Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Offen Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
Daniela88
Frischling


Verfasst am:
21. Apr 2014, 01:28
Rufname: Dani
Wohnort: im schönen Pott

Optimierung Makro Tabellenaktualisierung über 2 Arbeitsmappe - Optimierung Makro Tabellenaktualisierung über 2 Arbeitsmappe

Nach oben
       Version: Office 2003

Hallo zusammen und schöne Ostern,

nachfolgendes Makro braucht recht lange zur Durchführung, da ich mir das Makro aus verschiedenen Codes hier im Forum zusammen gebastelt habe hoffe dass es sich noch Verbessern/verschnellern lässt.
Die Quelldatei besteht aus ca. 100, vom Aufbau her, identischen Tabellen und kopiert werden davon je Durchlauf ca. 20.
Im Wesentlichen geht es darum dass aus der Quellmappe Tabellenblätter kopiert werden, wenn in C2 ein bestimmter Wert und in T2 kein Text steht, diese werden dann in einer neuen Mappe gespeichert. Speichername und Pfad werden im Code vorgegeben. Tabelle1 soll bei Erstellung einer neuen Mappe gelöscht werden, ansonsten wird der Abschnitt übersprungen. Falls die Mappe schon vorhanden ist werden die Daten in der Mappe nur aktualisiert. Wenn beim aktualisieren in T2 ein Datum übertragen wird soll auch diese Tabelle gelöscht werden.

Was mir noch fehlt ist eine korrekte Fehlerbehandlungsroutine zB. wenn die zu aktualisierende Mappe bereits geöffnet ist. Da weiß ich nicht genau wie ich da vorgehen muss.

Der gesamte Code des Makros lautet:
Code:
  Option Explicit

  Public Sub Gruppe_I_Filtern()
  Const strwksName = "Tabelle1" 'Überprüfen ob Tabelle1 vorhanden
  Dim wksTmp As Object
  Dim strGruppe As String, strPfad As String, strName As String
  Dim strOrdner As String, strOrdner2 As String
  Dim wkbQuelle As Workbook
  Dim wkbZiel As Workbook, wksZiel As Worksheet, wks As Worksheet
  Dim i As Long, lngSheets As Long, lngCalc As Long
  Dim rng As Range, rngZelle As Range
  Dim t As Double  ' Makroausführung messen
  t = Timer
    With Application
      .ScreenUpdating = False
      .EnableEvents = False
      lngCalc = .Calculation
      .Calculation = xlCalculationManual
  '    .DisplayAlerts = False
    End With

  Set wkbQuelle = ThisWorkbook
  strOrdner = "Gruppe_"
  strName = "Stammdaten_Doku_"
  strGruppe = Range("C2").Value
  strPfad = "D:\VW\Dokumentation\"

    If Len(Dir(strPfad & strName & strGruppe & ".xlsb")) = 0 Then
'      lngSheets = Application.SheetsInNewWorkbook
'      Application.SheetsInNewWorkbook = 1
      Set wkbZiel = Workbooks.Add
      Application.DisplayAlerts = False
      wkbZiel.SaveAs Filename:=strPfad & strOrdner & strGruppe & "\" & strName & strGruppe, FileFormat:=xlExcel12
      Application.DisplayAlerts = True
'      Application.SheetsInNewWorkbook = lngSheets
    Else
      Set wkbZiel = Workbooks.Open(strPfad & strOrdner & strGruppe & "\" & strName & strGruppe & ".xlsb")
    End If

    For i = 1 To wkbQuelle.Sheets.Count
      If wkbQuelle.Sheets(i).Range("C2") = "IV" And wkbQuelle.Sheets(i).Range("T2").Text = "" Then
        wkbQuelle.Sheets(i).Copy After:=wkbZiel.Sheets(wkbZiel.Sheets.Count) 'kopiere Tabelle, setze in neue Arbeitsmappe am Ende ein
        With ActiveSheet.UsedRange
         .Value = .Value
        End With
      End If
    Next i
   
    '--- Tabelle1 falls vorhanden löschen
    On Error Resume Next 'Bei Fehler : Fortfahren im Code
    Set wksTmp = Sheets(strwksName)
   
    If wksTmp Is Nothing Then
      Worksheets.Add.Name = strwksName
    Else
      Application.DisplayAlerts = False 'Ohne Löschabfrage
      wksTmp.Delete ' Tabelle1 löschen
      Application.DisplayAlerts = True
    End If
    Set wksTmp = Nothing
   
    '--- Wenn Ausstiegsdatum dann tabelle löschen
    For Each wksZiel In Sheets
    Application.DisplayAlerts = False
      If Len(Trim(wks.Cells(2, 20).Text)) > 0 Then
       wks.Delete
      End If
    Next
    Application.DisplayAlerts = True
   
    '--- Umwandeln der verbundenen Zellen
      Set rng = wksZiel.Cells.Range("A21:A26")
      For Each rngZelle In rng
        If rngZelle.MergeCells Then
          With rngZelle.MergeArea
          .UnMerge
          .HorizontalAlignment = xlCenterAcrossSelection
          .VerticalAlignment = xlCenter
          .Orientation = 0
    '--- Suchen und Ersetzen der Anrede
          rngZelle.Value = Replace(Replace(Replace(rngZelle.Value, Chr(13), " "), _
                                Chr(10), " "), "  ", " ")
          rngZelle.Value = Replace(Replace(Replace(rngZelle.Value, "Familie ", ""), _
                                "Frau ", ""), "  ", " ")
          rngZelle.Value = Replace(Replace(Replace(rngZelle.Value, "Herr ", ""), _
                                "Frau", ""), "  ", " ")
          End With
          i = i + 1 'erweitert
        End If
'            Application.StatusBar = "... wandle in Blatt: " & wksZiel & strName & " die " & i & ".rngZelle um"
      Next
    Next
'MsgBox "Es wurden " & i & " verbundene rngZellen umgewandelt! "
'Application.StatusBar = False

    If Not wkbZiel Is Nothing Then wkbZiel.Close SaveChanges:=True
   
Set wkbZiel = Nothing
Set wkbQuelle = Nothing

    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
'    .DisplayAlerts = True
  End With
MsgBox Timer - t & " sec", , "Makrolaufzeit"
End Sub

 

_________________
Mit freundlichen Gruße
Daniela
Gast



Verfasst am:
21. Apr 2014, 14:47
Rufname:

AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm - AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm

Nach oben
       Version: Office 2003

Hi,

was den Teil des Kopierens betrifft kann man dies auch so angehen:
Code:

  Dim wkbQuelle As Excel.Workbook
  Dim wksQuelle As Excel.Worksheet
  Dim wkbZiel   As Excel.Workbook
  Dim wksZiel   As Excel.Worksheet
  Dim shsZiel   As Excel.Sheets
 
  '<...>
 
  Set wkbQuelle = ThisWorkbook
  '<...>
  Set wkbZiel = ...
  '<...>
  Set shsZiel = wkbZiel.Sheets
 
  For Each wksQuelle In wkbQuelle.Worksheets
    If wksQuelle.Range("C2").Text = "IV" _
    And wksQuelle.Range("T2").Text = "" _
    Then
     
      'kopiere Tabelle, setze in neue Arbeitsmappe am Ende ein
     
      Set wksZiel = wkbZiel.Worksheets.Add(After:=shsZiel(shsZiel.Count))
      'wksZiel.Name = ...
     
      With wksQuelle.UsedRange
        .Copy
        With wksZiel.Range(.Address)
          .PasteSpecial xlPasteValues
          .PasteSpecial xlPasteFormats
        End With
        'Application.CutCopyMode = False
      End With
     
    End If
  Next

Das könnte möglicherweise etwas schneller ablaufen (probiers mal).

Du solltest im Umgang mit dem Sheets-Objekt vorsichtig sein.
Dieses gibt - neben einigen Altlasten von Excel - auch Chart-Objekte zurück. Du willst aber nur Tabellenblätter berücksichtigen, also Worksheets. Darum rate ich immer dazu dies strickt voneinander zu trennen, sich also gar nicht erst an den leichtsinnigen Umgang mit Sheets zu gewöhnen (das macht nur in einigen Fällen wirklich Sinn). Was ist z.B. wenn die Mappe dem Nutzer die Freiheit gewährt ein Diagrammblatt anzulegen. Er dürfte nicht zwingend ein Verständnis dafür haben wenn plötzlich Makros nicht mehr fehlerfrei laufen.

Im dem Abschnitt "Wenn Ausstiegsdatum" ist mit Sheets die Mappe in der gearbeitet wird nicht eindeutig festgelegt. Den Code der Reihe nach analysiert mag das zwar logisch und richtig sein (hab ich nicht überprüft), ich rate jedoch auch allein aufgrund der Lesbarkeit dazu die Mappe davor anzugeben, sowie Sheets durch Worksheets zu ersetzen (s. den Textabschnitt zuvor). Dadurch wird der Code robuster.

Ansonsten kann ich spontan nur sagen, dass ...
... man verbundene Zelle auch in einem Schritt voneinander trennen kann. Nur weiß ich nicht in wie weit das in deinem Fall hilfreich ist, da du noch Zellen anpasst.
... die Bearbeitung von Zellen über Arrays meist schneller abläuft, als der Zugriff über die jeweilige Methode (z.B. Cells-Methode).
... man mehere Blätter gleichzeitig löschen kann.
... man bei mehrmaligen Zugriff von/auf Methoden/Eigenschaften eines Objektes eine Variable dafür anlegen, oder mit der With-Anweisung arbeiten sollte. Jeder dieser Zugriffe benötigt schließlich Zeit und es macht keinen Sinn den gleichen Zugriff dreifach (oder mehr) auszuführen.

Vielleicht sieht jemand anderes noch Verbesserungsmöglichkeiten.

Gruß
Daniela88
Frischling


Verfasst am:
22. Apr 2014, 00:37
Rufname: Dani
Wohnort: im schönen Pott

AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm - AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm

Nach oben
       Version: Office 2003

Hallo lieber Helfer,

lieben Dank für Deine Hilfe.

In den Tabellen sind Druckbereiche, Spaltenbreiten, Zellhöhen und Seitenränder festgelegt, außerdem befinden sich ca. 30 Shapes darin die an Zellen ausgerichtet sind. Das müsste ich alles separat im Code festlegen. Habe es aber trotzdem ausprobiert und festgestellt dass die Shapes auch nicht mitgenommen werden. Allerdings braucht der Code tatsächlich nur ein Viertel der Zeit

Zitat:
Du solltest im Umgang mit dem Sheets-Objekt vorsichtig sein.

Ich bezweifle das meine Kollegen wissen wie man ein Diagramm anlegt, aber ich habe Deinen Rat befolgt und alle Sheets in Worksheets geändert und werde mich auch noch belesen was es mit dem Unterschied auf sich hat.

Den Abschnitt Ausstiegsdatum habe ich eindeutig referenziert, das hatte ich zuvor übersehen.

Mit den anderen Verbesserungsmöglichkeiten werde ich mich erst ein wenig belesen müssen um herauszufinden wie es funktioniert. Bin eben waschechter Anfänger…..

Eine Frage hätte ich noch warum setzt Du ein Excel. in zB. Dim wkbQuelle As Excel.Workbook ?

_________________
Mit freundlichen Gruße
Daniela
Gast



Verfasst am:
22. Apr 2014, 03:18
Rufname:

AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm - AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm

Nach oben
       Version: Office 2003

Zitat:

In den Tabellen sind Druckbereiche, Spaltenbreiten, Zellhöhen und Seitenränder festgelegt, außerdem befinden sich ca. 30 Shapes darin die an Zellen ausgerichtet sind. Das müsste ich alles separat im Code festlegen. Habe es aber trotzdem ausprobiert und festgestellt dass die Shapes auch nicht mitgenommen werden. Allerdings braucht der Code tatsächlich nur ein Viertel der Zeit

Ok.

Nun Shapes könnte man auch noch rüberkopieren (Zugriff über WorksheetObject.Shapes). Die anderen Dinge könnte man auch noch einzeln übernehmen, allerdings stellt sich dann schon die Frage ob es dann wirklich schneller ist als einfach nur das Blatt per Copy-Methode zu kopieren - ich vermute mal es wird dann nicht mehr schneller sein.

Übrigens:
Was für das Löschen mehrere Blätter gleichzeitig gilt, gilt auch für das Kopieren mehrer Blätter gleichzeitig - man übergibt dem Sheets-Objekt ein Array mit den entspr. Blattnamen (bzw. auch Indizes) und ruft dann die entspr. Methode auf.
z.B. so:
Code:

Dim v as Variant
v = Array("Tabelle1", "Tabelle2")
ThisWorkbook.Sheets(v).Copy(After:=...)

Du müsstest also das Array anhand deiner Kriteren zur Laufzeit erstellen (siehe ReDim-Anweisung).

Zitat:

Eine Frage hätte ich noch warum setzt Du ein Excel. in zB. Dim wkbQuelle As Excel.Workbook ?

Ist eine allgemeine Angewohnheit von mir.
Kommt dadurch das ich öfters anwendungsübergreifend programmiere. Vorallem bei der Range-Klasse macht sich das bemerkbar, da es diese sowohl in Word als auch in Excel gibt.
Arbeitet man z.B. nur in Excel ist das natürlich nicht nötig.

Gruß
Daniela88
Frischling


Verfasst am:
23. Apr 2014, 00:09
Rufname: Dani
Wohnort: im schönen Pott

AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm - AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm

Nach oben
       Version: Office 2003

Hallo lieber Helfer,

wow ich komm mir vor wie der Spatz unter einer Dampfwalze, zumindest qualmt mein Schädel genau so Smile
Mein Ergebnis nach 5 Stunden Arbeit siehst Du unten, bitte nicht zu arg zerreißen. Nach den ersten 4 Seiten über Array´s wusste ich schon nicht mehr was in der Ersten gestanden hatte, als ich dann noch Anfing ReDim–Anweisung zu lesen hatte ich nur noch Nebelwände im Kopf. Wie merkt ihr Euch das nur alle?

Ich hoffe der Ansatz stimmt, zumindest tut der Code was ich möchte. Allerdings bin ich noch nicht dahintergekommen wie ich die neu erstellte Mappe ansprechen muss, im Moment speichere ich immer nur die Quelldatei um, außerdem kopiere ich alle Verknüpfungen mit . Denke wenn Morgen mein Kopf weniger raucht bekomme ich Durchblick, heute klappt nichts mehr was ich versuche. Die Tabellen ins Array zu legen benötigt die Hälfte der Zeit des alten Codes.

Zitat:
Vorallem bei der Range-Klasse macht sich das bemerkbar,

Okay, dann habe ich Wikipedia doch richtig interpretiert. Dort wurde Range im Zusammenhang mit Excel.Sheet angegeben.

Code:
  Option Explicit

Sub GruppeFiltern()
  Dim arr()
  Dim strGruppe As String, strPfad As String, strName As String, strOrdner As String
  Dim wkbQuelle As Workbook, wkbZiel As Workbook
  Dim wks As Worksheet
  Dim lngCalc As Long
  Dim t As Double  ' Makroausführung messen
  t = Timer
    With Application
      .ScreenUpdating = False
      .EnableEvents = False
      lngCalc = .Calculation
      .Calculation = xlCalculationManual
    End With
 
  Set wkbQuelle = ThisWorkbook
  strOrdner = "Gruppe_"
  strName = "Stammdaten_Doku_"
  strGruppe = Range("C2").Value
  strPfad = "J:\Other documents\2\doku\"
 
  On Error GoTo ExportFehler

  ReDim arr(0)
    For Each wks In wkbQuelle.Worksheets
      If wks.Range("C2").Text = "I" _
      And wks.Range("T2").Text = "" _
      Then
        arr(UBound(arr)) = wks.Name
        ReDim Preserve arr(UBound(arr) + 1)
      End If
    Next

 ReDim Preserve arr(UBound(arr) - 1)
  Worksheets(arr).Copy
 
'  Set wkbZiel = ThisWorkbook
'  Application.DisplayAlerts = False
'  ThisWorkbook.SaveAs Filename:=strPfad & strOrdner & strGruppe & "\" & strName & strGruppe, FileFormat:=xlExcel12
'  AktiveWorkbook.SaveAs Filename:=strPfad & strOrdner & strGruppe & "\" & strName & strGruppe, FileFormat:=xlExcel12
'  wkbZiel.SaveAs Filename:=strPfad & strOrdner & strGruppe & "\" & strName & strGruppe, FileFormat:=xlExcel12
'  Application.DisplayAlerts = True
'  Set wkbZiel = ThisWorkbook

'   On Error GoTo 0
'   Exit Sub
 
   
ExportFehler:

  MsgBox "Error " & Err.Number & " (" & Err.Description & _
  ") in procedure GruppeFiltern in Zeile " & Erl
   
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
  End With
 
MsgBox Timer - t & " sec", , "Makrolaufzeit"
End Sub 

_________________
Mit freundlichen Gruße
Daniela
Daniela88
Frischling


Verfasst am:
25. Apr 2014, 03:15
Rufname: Dani
Wohnort: im schönen Pott

AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm - AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm

Nach oben
       Version: Office 2003

Hallo lieber Gast,

nochmals Danke für Deine Hilfe.

Das Ergebniss Deiner Vorschläge, die ich hoffentlich korrekt umgesetzt habe, benötigt immer noch 35 Sekunden. Das ist aber schon erheblich weniger als mein Erster Versuch Smile
Die Aufhebung des Zeilenverbundes habe ich in der Quellmappe getätigt, da diese nur zur Erfassung von Daten dient die in den Stammdaten nichts zu suchen haben und zu weiteren Aufteilungen benötigt wird war das Okay.

Ich versuche mich gerne weiter an Optimierungsvorschlägen Smile

Code:
Option Explicit

Sub GruppeFiltern()
  Dim wkbQuelle As Workbook, wkbZiel As Workbook
  Dim wks As Worksheet, wksZiel As Worksheet
  Dim arr()
  Dim strGruppe As String, strPfad As String, strName As String
  Dim strOrdner As String
  Dim lngCalc As Long
  Dim t As Double  ' Makroausführung messen

  t = Timer
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
  End With
 
  Set wkbQuelle = ThisWorkbook
  strOrdner = "Gruppe_"
  strName = "Stammdaten_Doku_"
  strGruppe = Range("C2").Value
  strPfad = "J:\Other documents\2\doku\"
 
  '--- Tabellen kopieren
  ReDim arr(0)
    For Each wks In wkbQuelle.Worksheets
    If wks.Cells(2, 3).Text = "I" _
      And wks.Cells(2, 20).Text = "" _
      Then
        arr(UBound(arr)) = wks.Name
        ReDim Preserve arr(UBound(arr) + 1)
      End If
    Next

  ReDim Preserve arr(UBound(arr) - 1)
  Worksheets(arr).Copy
   
  '--- Ersetzen Herr, Frau, Familie
  DeleteErsetze Range("A21:A26")
 
  '--- Wenn Ausstiegsdatum vorhanden dann Tabelle löschen
  Set wkbZiel = ActiveWorkbook
  ReDim arr(0)
    For Each wks In wkbZiel.Worksheets
      If wks.Cells(2, 20).Text > "" Then
        arr(UBound(arr)) = wks.Name
        ReDim Preserve arr(UBound(arr) + 1)
       
        ReDim Preserve arr(UBound(arr) - 1)
        Application.DisplayAlerts = False
          Worksheets(arr).Delete
        Application.DisplayAlerts = True
      End If
     
  '--- Formeln in Werte wandeln
        wks.UsedRange.Cells.Copy
        wks.UsedRange.PasteSpecial Paste:=xlValues
    Next wks

  '--- Dateiname für neue Mappe festlegen
  Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs Filename:=strPfad & strOrdner & strGruppe & "\" & strName & strGruppe, FileFormat:=xlExcel12
  Application.DisplayAlerts = True
   
  '--- Schließen und Speichern der neuen Mappe
    If Not wkbZiel Is Nothing Then wkbZiel.Close SaveChanges:=True
 
  Set wkbZiel = Nothing
  Set wkbQuelle = Nothing

  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
  End With
   
  MsgBox Timer - t & " sec", , "Makrolaufzeit"
End Sub


Sub DeleteErsetze(ByVal Bereich As Range)
  Dim Zelle As Range
 
    For Each Zelle In Bereich
      With Zelle.Value
        Zelle.Value = Replace(Replace(Replace(Replace(Replace(Replace(Zelle.Value, _
        Chr(13), " "), Chr(10), " "), "Familie ", ""), "Frau ", ""), _
        "Herr ", ""), "  ", " ")
      End With
    Next Zelle
  Set Zelle = Nothing
End Sub

_________________
Mit freundlichen Gruße
Daniela
Isabelle :-)
Menschin


Verfasst am:
25. Apr 2014, 09:24
Rufname:
Wohnort: Westlicher Spiralarm der Galaxis

AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm - AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm

Nach oben
       Version: Office 2003

Hallöchen,

1. Redim Preserve ist ziemlich langsam. Du solltest, wenn es geht und die maximale Obergrenze des Arrays schon feststeht (in dem Fall die Anzahl der Tabellen in der Mappe) das Array erst darauf festlegen, einen Indexzähler mitlaufen lassen und nach dem Füllen des Arrays diese auf die Anzahl der Einträge reduzieren. Damit musst du Redim Preserve nur einmal ausführen.

2. In der zweiten Schleife ist irgendwie Unsinn.

Code:
      If wks.Cells(2, 20).Text > "" Then
        arr(UBound(arr)) = wks.Name
        ReDim Preserve arr(UBound(arr) + 1)
       
        ReDim Preserve arr(UBound(arr) - 1)
        Application.DisplayAlerts = False
          Worksheets(arr).Delete
        Application.DisplayAlerts = True
      End If


Hier prüfst du nochmal Cells(2, 20) und löschst alle Tabellen die da nicht leer sind, hast aber in der ersten Schleife schon eine abfrage drin aufgrund der nur Tabellen kopiert werden die in Cells(2, 20) leer sind. Macht das Sinn?

3. Zu deinen Variablen. Eine Objektvariable für ThisWorkbook ist Unsinn, denn da kannst du doch gleich ThisWorkbook nehmen. Variablen die konstante Werte enthalten (strOrdner, strName und strPfad) solltest du auch als Konstanten anlegen.

4. Die Prozedur "DeleteErsetze" arbeitet nur auf der ersten der kopierten Tabellen. Kann n das richtig sein?

5. Am Ende deines Makros speicherst du und in der nächsten Zeile nochmal. Das macht keinen Sinn.

Abhängig von der Anzahl der kopierten Tabellen und der Größe der Listen darin sollte das maximal 5 Sekunden dauern.

_________________
LG Isi

Die Mitgliedschaft im Forum erhöht deine Chance auf eine Antwort von mir um 99,999%
Daniela88
Frischling


Verfasst am:
25. Apr 2014, 10:13
Rufname: Dani
Wohnort: im schönen Pott

AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm - AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm

Nach oben
       Version: Office 2003

Hallo Isi,

vorab erst mal Danke das Du mir helfen möchtest.

zu 1. Redim Preserve hatte ich gewählt weil die Obergrenze leider nicht feststeht. Es sind immer unterschiedlich viele Tabellen zu Übertrage. Ich übertrage sechs verschiedene Gruppen, von römisch I bis IV , in jeder Gruppe sind unterschiedlich viele Patienten, Patienten können die Gruppe wechseln oder versterben, oder ausziehen usw. Deshalb hatte ich diese Variante gewählt. Denke ich da in die falsche Richtung?

Zu 2.
Ja, auf den Ersten Blick und auch weil ich nicht ins Detail geschildert habe was ich mache sieht das ziemlich Unsinnig aus. Aber nachdem die Mappe einmal erstellt ist wird sie meistens nur noch aktualisiert. Wenn dann ein Bewohner auszieht habe ich in der Quellmappe das Ausstiegsdatum eingegeben und der Patient (die Tabelle) wird nicht mehr übertragen aber in der Zielmappe ist der Patient noch vorhanden. Dort tragen unsere Mitarbeiter das Ausstiegsdatum ein, dann wird der Patient beim aktualisieren der Mappe auch gelöscht. Evtl ist es eine Überlegung wert die Zielmappen generell neu zu Erstellen, dann würde das Doppelgemoppel wegfallen. Allerdings muss ich vor jeder Aktualisierung die Zielmappen mit der Quellmape (mache ich momentan manuell, was viel Zeit kostet) miteinander vergleichen da die Mitarbeiter dort Änderungen eintragen die nicht in den Stammdaten dokumentiert werden. Oberste Hierarchie ist die Mappe Stammdaten, dort werden alle relevanten Daten der Patienten eingetragen, danach kommt die Quelldatei die diese Daten in ein Stammdatenblatt für Dokumentationen einträgt, danach entsteht meine jetzigen Zielmappen die in den jeweiligen Gruppen mit den dazugehörigen Patienten aufgeteilt sind, die Mitarbeiter drucken diese aus und tragen dort ihre Daten hinein. Diese Daten übertrage ich dann wiederrum in die Quelldatei und aktualisiere anschließend die Daten der Mitarbeiter. Wahrscheinlich mache ich das wieder mal alles zu kompliziert, aber als ich damit angefangen habe konnte ich in Excel nur Eintragungen machen. Formeln und VBA waren bis dahin ein Brief mit 7 Siegeln für mich.

Zu3. Wird geändert

Zu4. Ups da hast Du Recht wird auch geändert. Kommt davon wenn man nur immer die aktuell geöffnete tabelle betrachtet

Zu5. Wird natürlich ebenfalls geändert.

Wow 5 Sekunden, ich glaub bis dahin hab ich ein paar graue Haare mehr.
Vielen Dank für Deine konstruktiven Tipps, nach der Arbeit werde ich mich an den Änderungen begeben. Na, das nenne ich doch mal eine sinnvolle Pause Smile

_________________
Mit freundlichen Gruße
Daniela
Isabelle :-)
Menschin


Verfasst am:
25. Apr 2014, 10:29
Rufname:
Wohnort: Westlicher Spiralarm der Galaxis

AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm - AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm

Nach oben
       Version: Office 2003

Hallöchen,

zu 1.: Die maximale Obergrenze steht schon fest, das ist die Anzahl der Tabellen in der Ursprungsmappe. Mehr können es keinesfalls sein. Also das Array erst auf diese Obergrenze dimensionieren, einen Zähler mitlaufen lassen der die Anzahl der Einträge mitzählt und am Ende das Array auf diese Zahl wieder zurück dimensionieren.

Code:
    ReDim arr(1 To ThisWorkbook.Worksheets.Count)
   
    For Each wks In ThisWorkbook.Worksheets
   
        With wks
   
            If .Cells(2, 3).Value = "I" Then
           
                If IsEmpty(.Cells(2, 20).Value) Then
               
                    lngIndex = lngIndex + 1
                    arr(lngIndex) = wks.Name
                   
                End If
            End If
        End With
    Next
   
    ReDim Preserve arr(1 To lngIndex)
    Worksheets(arr).Copy

Achso, du solltest die Text-Eigenschaft der Zellen nur benutzen, wenn du den Inhalt der Zellen irgendwo so darstellen willst wie es in der Zelle steht. Z.B. in einer TextBox. Ansonsten ist die Abfrage dieser Eigenschaft wesentlich langsamer als die der Value-Eigenschaft. Und wenn du damit den Fehlerwert einer Formel abfangen willst, dann ist die IsError-Funktion das Mittel der Wahl.

_________________
LG Isi

Die Mitgliedschaft im Forum erhöht deine Chance auf eine Antwort von mir um 99,999%
Daniela88
Frischling


Verfasst am:
28. Apr 2014, 23:21
Rufname: Dani
Wohnort: im schönen Pott

AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm - AW: Optimierung Makro Tabellenaktualisierung über 2 Arbeitsm

Nach oben
       Version: Office 2003

Hallo Isi,
ich geb´s auf, komme nicht weiter mit dieser Codezeile. Die Zeile
Code:
  If IsEmpty(.Cells(2, 20).Value) Then 

Raubt mir alle Nerven. In Zelle 2, 20 ist eine Formel enthalten und das Array liefert Fehler:
Index außerhalb des gültigen Bereich in Codezeile
Code:
  ReDim Preserve arr(1 To lngIndex)


Ich habe die letzten Tage so viel darüber gelesen das ich nichts mehr aufnehmen kann, es war einfach nie das richtige dabei oder aber wahrscheinlicher ist: ich sehe den Wald vor lauter Bäumen nicht mehr.

Weil ich nicht dahinter gekommen bin wie ich das Datum ansonsten prüfen kann prüfe ich so:
Code:
If wks.Cells(2, 20).Value = "" Then


Während ich dann versuchte das zweite Array, zum Tabelle löschen, in die Gänge zu bekommen vielen mir dann die Schuppen von den Augen. Du hattest Recht es ist unsinnig, ich überschreibe ja die komplette Arbeitsmappe nicht die einzelnen Tabellen. Sorry manchmal sind meine Gedankengänge etwas verquert.

Ich hoffe ansonsten habe ich alles umgebaut was Du mir vermitteln wolltest und das so hoffe ich auch richtig. Für weitere Tipps und Tricks bin ich gerne offen.

Nun zu der Makrozeit. Ich habe mal getestet was wie lange braucht um herauszufinden wo es hapert. Die Rangliste ergibt folgendes:

1. Kopiervorgang = 0,25 Sekunden
2. Einfügen der Tabellen in neue Mappe = 26,67 Sekunden
3. Speichern der Mappe = 3 Sekunden
4. Werte ersetzten, Replace Anrede = 2,64 Sekunden
Gesamtzeit also 32,56 Sekunden.

Ich denke das Ergebnis ist eindeutig, getestet habe ich mit der neuen Mappe die am wenigsten Datenvolumen rüber schaufeln muss (8 Tabellen). In den Daten sind außer jeder Menge Formeln noch 19 Shapes und 25 Forms Typ Check Box, evtl. liegt es daran.
Übrigens brauch der alte Code, den ich aktualisiert habe um Vergleiche zu ziehen 34,06 Sekunden.

So sieht der Code zurzeit aus:
Code:
 Option Explicit
Public Const DATEIPFAD  As String = "D:\VW\Dokumentation\"
Public Const ORDNERNAME As String = "Gruppe_"
Public Const DATEINAME As String = "Stammdaten_Doku_"

Sub GruppeFiltern_alt()
  Dim wkbQuelle As Workbook, wkbZiel As Workbook
  Dim wks As Worksheet, wksZiel As Worksheet
  Dim arr()
  Dim arrSuch()
  Dim arrErsetz()
  Dim strGruppe As String
  Dim lngCalc As Long, SuEr As Long, lngIndex As Long
  Dim t As Double  ' Makroausführung messen
 
  t = Timer
  strGruppe = Range("C2").Value
  arrSuch = Array("Frau", "Herrn", "Herr", "Familie", Chr(13), Chr(10))
  arrErsetz = Array("", "", "", "", " ", " ")
 
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
  End With
 
  '--- Tabellen kopieren
  ReDim arr(0)
    For Each wks In ThisWorkbook.Worksheets
      With wks
        If wks.Cells(2, 3).Value = "I" Then
          If wks.Cells(2, 20).Value = "" Then
            arr(UBound(arr)) = wks.Name
            ReDim Preserve arr(UBound(arr) + 1)
          End If
        End If
      End With
    Next
  ReDim Preserve arr(UBound(arr) - 1)
  Worksheets(arr).Copy
 
  '--- Wenn Ausstiegsdatum vorhanden dann Tabelle löschen
'  Set wkbZiel = ActiveWorkbook
    For Each wks In ActiveWorkbook.Worksheets
      With wks
  '--- Formeln in Werte wandeln
            .UsedRange.Cells.Copy
            .UsedRange.PasteSpecial Paste:=xlValues
  '--- Suchen und Ersetzen

        For SuEr = LBound(arrSuch) To UBound(arrSuch)
          Call .Range("A21:A26").Replace(arrSuch(SuEr), _
          arrErsetz(SuEr), , , False)
        Next
      End With
    Next
  '--- Dateiname für neue Mappe festlegen, Speichern und Schließen
  Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs Filename:=DATEIPFAD & ORDNERNAME & strGruppe & "\" & _
  DATEINAME & strGruppe, FileFormat:=xlExcel12
'  wkbZiel.Close
  Application.DisplayAlerts = True

  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
  End With
  MsgBox Timer - t & " sec", , "Makrolaufzeit"
End Sub

_________________
Mit freundlichen Gruße
Daniela
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: automatisches makro 5 sisku46 1297 08. Aug 2007, 09:12
sisku46 automatisches makro
Keine neuen Beiträge Excel Formeln: Brauche Hilfe! Formel und/oder VBA (Makro) 2 ::Patrick:: 2927 01. Aug 2007, 10:42
Gast Brauche Hilfe! Formel und/oder VBA (Makro)
Keine neuen Beiträge Excel Formeln: Sicherheitsabfrage vor Makro schalten 4 Gismo2 1521 10. Jul 2007, 07:49
Gismo2 Sicherheitsabfrage vor Makro schalten
Keine neuen Beiträge Excel Formeln: Werte innerhalb einer Arbeitsmappe automatisch übertragen 4 Manni55 570 13. Jun 2007, 20:19
Manni55 Werte innerhalb einer Arbeitsmappe automatisch übertragen
Keine neuen Beiträge Excel Formeln: Namenfeld der Zelle mittels Formel oder Makro benennen 2 cehrat 1181 24. Mai 2007, 16:55
fridgenep Namenfeld der Zelle mittels Formel oder Makro benennen
Keine neuen Beiträge Excel Formeln: Zelleninhalt in andere Arbeitsmappe übernehmen (Füllfarbe) 0 kosch75 1495 18. Jan 2007, 23:43
kosch75 Zelleninhalt in andere Arbeitsmappe übernehmen (Füllfarbe)
Keine neuen Beiträge Excel Formeln: Blattschutz und Makro 5 Nicole-Fun 6668 10. Jan 2007, 13:06
muenzc Blattschutz und Makro
Keine neuen Beiträge Excel Formeln: Lese- und Schreibschutz über Makro 0 steven143 876 18. Dez 2006, 13:52
steven143 Lese- und Schreibschutz über Makro
Keine neuen Beiträge Excel Formeln: End up, Markieren, Löschen mit Makro 10 detlef42 1290 21. Nov 2006, 16:13
Detlef 42 End up, Markieren, Löschen mit Makro
Keine neuen Beiträge Excel Formeln: Makro mit Selection.AutoFill 2 GastAlex 3911 18. Okt 2006, 15:25
GastAlex Makro mit Selection.AutoFill
Keine neuen Beiträge Excel Formeln: SAP EXCEL Makro WDPDDMAC.XLS 2 tschuett 4313 15. Sep 2006, 08:42
tschuett SAP EXCEL Makro WDPDDMAC.XLS
Keine neuen Beiträge Excel Formeln: Makro entfernen 4 Holger 996 979 07. Sep 2006, 09:29
brans Makro entfernen
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Microsoft Excel Tricks