Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 10:08:11
Summieren von Zellen mit bedingter Formatierung
26.04.2024 09:08:00
Export alle Tabellenblätter als csv - in bestimmten Ordner
26.04.2024 08:56:40
Über alle Spalten nur €-Werte zählen
26.04.2024 08:08:24
Pivot Vormonatsveränderung
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1836to1840
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1836to1840
1836to1840
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Perfomance VBA Makro

Perfomance VBA Makro
09.07.2021 13:04:46
stef26
Hallo Liebe Excelprofis,
ich habe ein kleines Problem und könnte mal von euch gute Ratschläge benötigen.
Ich habe eine Excelliste mit der ich über ein Makro eine andere Excelliste öffne und mir dort etliche Daten reinkopiere.
Das Makro läuft bisher ca. 30 Sekunden.
Nun habe ich folgendes geändert:
Ich habe ein Tabellenblatt mit ein paar kleinen Bildern und Beschreibungen eingefügt.
In einem Tabellenblatt kann über ein Pulldownmenü dann das Bild entsprechende Bild angezeigt werden.
Es funktioniert auch alles wie es soll. Das Problem was ich jetzt jedoch habe ist, dass dadurch das Makro zwar fehlerfrei läuft, jedoch für die Bearbeitung keine 30 sekunden sondern über 7min benötigt, obwoch ich am Makro keine Änderungen vorgenommen habe.
Nehme ich die indirekt Formel aus dem Namensmanager wieder raus, so läuft das Makro wieder in 30Sekunden.
Gibt es da eine Möglichkeit in VBA, wie ich das verhindern kann, dass die Bearbeitungszeit des Makros so viel länger wird?
Was ich schon probiert habe ist:
Berechnung auf manuell zu stellen während das Makro läuft. bringt keine Verbesserung
Bildschirmreaktionen sind sowieso ausgeschaltet, während der Bearbeitung.
Gruß
Stefan

15
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: tolles Makro oT
09.07.2021 13:10:42
JoWE
AW: Perfomance VBA Makro
09.07.2021 13:10:49
GerdL
Hallo Stefan,
google mal nach get more speed und / oder zeige dein Makro.
Gruß Gerd
Fehler in Zeile 28
09.07.2021 13:22:34
UweD
:-)
zeig den Code
AW: Perfomance VBA Makro
09.07.2021 13:38:39
stef26
Der Code ist zwar extrem unübersichtlich, ist halt jahrelang immer wieder geändert worden.
Ich wollte ihn deswegen auch nicht zeigen. Zudem kann man nicht erwarten, da Optimierungen zu machen
Und weil der Code ja ohne diesen INDEX im Namensmangager ganz gut durch läuft.
Da ich weiß, dass es an der Formel im Namensmanager liegt, würde ich da eher ansetzen wollen...

Sub Daten_alt_kopieren()
Application.StatusBar = False
Dim wbNeu As Workbook
Dim wbAlt As Workbook
Dim Umlaute As Long
Rem hier alle Tabellen (Vorlage & Alt) eintragen
Dim wks_Grunddaten_Neu As Worksheet, wks_Grunddaten_Alt As Worksheet
Dim wks_Streckenkopf_Neu As Worksheet, wks_Streckenkopf_Alt As Worksheet
Dim wks_SMDRuesten_Neu As Worksheet, wks_SMDRuesten_Alt As Worksheet
Dim wks_SMDL_Neu As Worksheet, wks_SMDL_Alt As Worksheet
Dim wks_SMDB_Neu As Worksheet, wks_SMDB_Alt As Worksheet
Dim wks_AOI_Neu As Worksheet, wks_AOI_Alt As Worksheet
Dim wks_VORB_Neu As Worksheet, wks_VORB_Alt As Worksheet
Dim wks_VORM_Neu As Worksheet, wks_VORM_Alt As Worksheet
Dim wks_HAND_Neu As Worksheet, wks_HAND_Alt As Worksheet
Dim wks_PRESS_Neu As Worksheet, wks_PRESS_Alt As Worksheet
Dim wks_FERT1_Neu As Worksheet, wks_FERT1_Alt As Worksheet
Dim wks_FERT2_Neu As Worksheet, wks_FERT2_Alt As Worksheet
Dim wks_FERT3_Neu As Worksheet, wks_FERT3_Alt As Worksheet
Dim wks_INSEL_Neu As Worksheet, wks_INSEL_Alt As Worksheet
Dim wks_PRUEF1_Neu As Worksheet, wks_PRUEF1_Alt As Worksheet
Dim wks_PRUEF2_Neu As Worksheet, wks_PRUEF2_Alt As Worksheet
Dim wks_PRUEF3_Neu As Worksheet, wks_PRUEF3_Alt As Worksheet
Dim wks_DIFFALL As Worksheet
Dim wks_SELEKTIV_Neu As Worksheet, wks_SELEKTIV_Alt As Worksheet
Dim wks_SELEKTIV2_Neu As Worksheet
Dim wks_WASCHEN_Neu As Worksheet
Dim wks_DAMPFL_Neu As Worksheet
Dim wks_DAMPFB_Neu As Worksheet
Dim wks_Takt_Neu As Worksheet, wks_Takt_Alt As Worksheet
Dim wks_Report_Neu As Worksheet, wks_Report_Alt As Worksheet
Rem Dim fuer Differenzberechnung
Dim wks_diff As Worksheet
Dim wks_diff1 As Worksheet
Dim wks_diff2 As Worksheet
Dim wks_diff3 As Worksheet
Dim wks_diff4 As Worksheet
Dim wks_diff5 As Worksheet
Dim wks_diff6 As Worksheet
Dim wks_diff7 As Worksheet
Dim wks_diff8 As Worksheet
Dim wks_diff9 As Worksheet
Dim wks_diff10 As Worksheet
Dim Zeile_Diff As Long, Spalte As Long
Dim vAuswahl
Dim Zeile_Alt As Long, vWert_B, Zelle_Wert_B As Range
Dim VerzeichnisAktiv As String
Dim StatusCalc As Long
Dim VerzeichnisAlt As String
If ThisWorkbook.Sheets("Grunddaten").Range("J9").Value = 1 Then
VerzeichnisAlt = ThisWorkbook.Sheets("Setup").Range("B1")
VerzeichnisAktiv = ThisWorkbook.Sheets("Setup").Range("B1")
Else
VerzeichnisAlt = ThisWorkbook.Sheets("Setup").Range("B2")
VerzeichnisAktiv = ThisWorkbook.Sheets("Setup").Range("B2")
End If
' hier werden alle notwendigen Tabellen der Vorlage gesetzt
Set wbNeu = ThisWorkbook
Set wks_Grunddaten_Neu = wbNeu.Worksheets("Grunddaten")
Set wks_Streckenkopf_Neu = wbNeu.Worksheets("Streck.- Aendern LP")
Set wks_SMDRuesten_Neu = wbNeu.Worksheets("SMD-Ruesten Material")
Set wks_SMDL_Neu = wbNeu.Worksheets("SMD-Bestuecken_L")
Set wks_SMDB_Neu = wbNeu.Worksheets("SMD-Bestuecken_B")
Set wks_AOI_Neu = wbNeu.Worksheets("AOI")
Set wks_VORB_Neu = wbNeu.Worksheets("THT_Baut. vorb")
Set wks_VORM_Neu = wbNeu.Worksheets("THT_Leit. vorm")
Set wks_HAND_Neu = wbNeu.Worksheets("THT-Handbest.")
Set wks_PRESS_Neu = wbNeu.Worksheets("THT_Einpresst.")
Set wks_FERT1_Neu = wbNeu.Worksheets("THT_Fert.mont_1")
Set wks_FERT2_Neu = wbNeu.Worksheets("THT_Fert.mont_2")
Set wks_FERT3_Neu = wbNeu.Worksheets("THT_Fert.mont_3")
Set wks_INSEL_Neu = wbNeu.Worksheets("Fertigungsinsel")
Set wks_PRUEF1_Neu = wbNeu.Worksheets("Pruefen")
Set wks_PRUEF2_Neu = wbNeu.Worksheets("Pruefen 2")
Set wks_PRUEF3_Neu = wbNeu.Worksheets("Pruefen 3")
Set wks_SELEKTIV_Neu = wbNeu.Worksheets("Selektivloeten")
Set wks_SELEKTIV2_Neu = wbNeu.Worksheets("Selektivloeten_2")
Set wks_WASCHEN_Neu = wbNeu.Worksheets("Waschen")
Set wks_DAMPFL_Neu = wbNeu.Worksheets("SMD-Dampfphase_L")
Set wks_DAMPFB_Neu = wbNeu.Worksheets("SMD-Dampfphase_B")
Set wks_Takt_Neu = wbNeu.Worksheets("Taktzeit")
Set wks_Report_Neu = wbNeu.Worksheets("AssemblyReport")
'Altdatei auswaehlen
VerzeichnisAktiv = VBA.CurDir 'aktives Verzeichnis merken
vAuswahl = Application.Dialogs(xlDialogOpen).Show(Arg1:=Sheets("Setup").Range("B1"))
If vAuswahl = False Then Exit 


Sub 'oeffnen-Dialog wurde abgebrochen
'Makrobremsen loesen
With Application
.EnableEvents = False
StatusCalc = .Application.Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Ab der Version 261 wurden die Tabellennamen geändert, damit keine Umlaute mehr vorhanden sind - > sonst laufen die Makros in China nicht mehr
If Sheets("Grunddaten").Range("J1").Value >= 261 Then
Umlaute = 1  ' neue Versionen mit Tabellenblätter mit ue/oe/ae
Else
Umlaute = 0   ' Ältere Versionen kleiner 261 mit Tabellenblätter mit ü/ö/ä
End If
Set wbAlt = ActiveWorkbook
' hier werden alle notwendigen Tabellen der gewählten alten Excel Kalkulation gesetzt
On Error Resume Next
If Umlaute = 1 Then
Set wks_Streckenkopf_Alt = wbAlt.Worksheets("Streck.- Aendern LP")
Else
Set wks_Streckenkopf_Alt = wbAlt.Worksheets("Streck.- Ändern LP")
End If
Set wks_Grunddaten_Alt = wbAlt.Worksheets("Grunddaten")
Set wks_VORB_Alt = wbAlt.Worksheets("THT_Baut. vorb")
Set wks_VORM_Alt = wbAlt.Worksheets("THT_Leit. vorm")
Set wks_HAND_Alt = wbAlt.Worksheets("THT-Handbest.")
Set wks_PRESS_Alt = wbAlt.Worksheets("THT_Einpresst.")
Set wks_FERT1_Alt = wbAlt.Worksheets("THT_Fert.mont_1")
Set wks_FERT2_Alt = wbAlt.Worksheets("THT_Fert.mont_2")
Set wks_FERT3_Alt = wbAlt.Worksheets("THT_Fert.mont_3")
' aenderung mit Version 247
If Umlaute = 1 Then
Set wks_SMDRuesten_Alt = wbAlt.Worksheets("SMD-Ruesten Material")
Set wks_SMDL_Alt = wbAlt.Worksheets("SMD-Bestuecken_L")
Set wks_SMDB_Alt = wbAlt.Worksheets("SMD-Bestuecken_B")
Else
Set wks_SMDRuesten_Alt = wbAlt.Worksheets("SMD-Rüsten Material")
Set wks_SMDL_Alt = wbAlt.Worksheets("SMD-Bestücken_L")
Set wks_SMDB_Alt = wbAlt.Worksheets("SMD-Bestücken_B")
End If
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 263 Then
'Übernahme der SMD Daten, wenn diese bereits über SIPRO (Technologie) kalkuliert wurden
'SMD-Bestuecken_L
'SMD-Bestuecken_L
With wbAlt.Worksheets("SMD-Bestuecken_L")
.Range("F20").Copy Destination:=wbNeu.Worksheets(.Name).Range("F20") 'Pasteninspektion notwendig
.Range("F10").Copy Destination:=wbNeu.Worksheets(.Name).Range("F10") 'Lötprogramm
.Range("F14").Copy Destination:=wbNeu.Worksheets(.Name).Range("F14") 'Länge
.Range("F16").Copy Destination:=wbNeu.Worksheets(.Name).Range("F16") 'Breite
.Range("E18").Copy Destination:=wbNeu.Worksheets(.Name).Range("E18") 'Losgröße
End With
'SMD-Bestuecken_B
With wbAlt.Worksheets("SMD-Bestuecken_B")
.Range("F20").Copy Destination:=wbNeu.Worksheets(.Name).Range("F20") 'Pasteninspektion notwendig
.Range("F10").Copy Destination:=wbNeu.Worksheets(.Name).Range("F10") 'Lötprogramm
.Range("F14").Copy Destination:=wbNeu.Worksheets(.Name).Range("F14") 'Länge
.Range("F16").Copy Destination:=wbNeu.Worksheets(.Name).Range("F16") 'Breite
End With
End If
End With
'Ende SMD ****************************************************************************************************************
' Grunddaten
With wbAlt.Worksheets("Grunddaten")
.Range("B3").Copy Destination:=wbNeu.Worksheets(.Name).Range("B3") 'Sachnummer
.Range("B7").Copy Destination:=wbNeu.Worksheets(.Name).Range("B7") 'Nutzen
.Range("E7").Copy Destination:=wbNeu.Worksheets(.Name).Range("E7") 'E-Stand
.Range("B7").Copy Destination:=wbNeu.Worksheets(.Name).Range("B7") 'Nutzen
.Range("I7").Copy Destination:=wbNeu.Worksheets(.Name).Range("I7") 'Art
.Range("D9:F9").Copy Destination:=wbNeu.Worksheets(.Name).Range("D9:F9") 'Fepla
.Range("A15:J30").Copy Destination:=wbNeu.Worksheets(.Name).Range("A15:J30") 'Historie
'Zeitaufnahmen nur bei neuerer Ausgabe uebernehmen
If .Range("A36").Value = "Arbeitsgang:" Then
.Range("D37:M56").Copy Destination:=wbNeu.Worksheets(.Name).Range("D37:M56") 'Zeitaufnahmen
.Range("N49:N51").Copy Destination:=wbNeu.Worksheets(.Name).Range("N49:N51") 'Zeitaufnahmen
Else
End If
End With
'Blatt "Streckenkopf" B abgleichen - Werte aus Spalten H & M:N von Alt nach Neu kopieren
With wks_Streckenkopf_Alt
For Zeile_Alt = 17 To 53
'Wert in Altdatei-Spalte B
vWert_B = .Cells(Zeile_Alt, 2).Value
If vWert_B  "" Then
'Wert in neuer Datei Spalte B suchen
With wks_Streckenkopf_Neu
Set Zelle_Wert_B = .Range(.Cells(17, 2), .Cells(53, 2)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole) '  Zeile 17 bis 53 checken Spalte B
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff Is Nothing Then
'Tabellenblatt fuer Abweichungen anlegen
Set wks_diff = wbNeu.Worksheets.Add(After:=wks_Streckenkopf_Neu)
wks_diff.Name = "Diff-STRK"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
If .Cells(Zeile_Alt, 8)  "" Then
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff.Cells(Zeile_Diff, 1)
End If
Else
'Werte aus Spalten H von Alt nach Neu kopieren wenn nicht gesperrt ist
If .Cells(Zeile_Alt, 8).AllowEdit = False Then
Else
.Cells(Zeile_Alt, 8).Copy _
Destination:=wks_Streckenkopf_Neu.Cells(Zelle_Wert_B.Row, 8)
End If
'Werte aus Spalten M:N von Alt nach Neu kopieren
.Range(.Cells(Zeile_Alt, 13), .Cells(Zeile_Alt, 14)).Copy _
Destination:=wks_Streckenkopf_Neu.Cells(Zelle_Wert_B.Row, 13)
End If
End If
Next
End With
'Kopieren von Standard Daten (leere Inhalt von B)
' Streckenkopf
If Umlaute = 1 Then
With wbAlt.Worksheets("Streck.- Aendern LP")
.Range("H29:H30").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("H29:H30") 'trennen
.Range("M29:N30").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("M29:N30") 'trennen Bemerkung
.Range("H34:H36").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("H34:H36") 'bohren
.Range("M34:N36").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("M34:N36") 'bohren Bemerkung
.Range("H42:H43").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("H42:H43") 'beschriften
.Range("M42:N43").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("M42:N43") 'beschriften Bemerkung
.Range("H48").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("H48") 'Griplets
.Range("M48").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("M48") 'Griplets Bemerkung
.Range("H53").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("H53") 'sonstiges
.Range("M53").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("M53") 'sonstiges Bemerkung
End With
Else
With wbAlt.Worksheets("Streck.- Ändern LP")
.Range("H29:H30").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("H29:H30") 'trennen
.Range("M29:N30").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("M29:N30") 'trennen Bemerkung
.Range("H34:H36").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("H34:H36") 'bohren
.Range("M34:N36").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("M34:N36") 'bohren Bemerkung
.Range("H42:H43").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("H42:H43") 'beschriften
.Range("M42:N43").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("M42:N43") 'beschriften Bemerkung
.Range("H48").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("H48") 'Griplets
.Range("M48").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("M48") 'Griplets Bemerkung
.Range("H53").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("H53") 'sonstiges
.Range("M53").Copy Destination:=wbNeu.Worksheets("Streck.- Aendern LP").Range("M53") 'sonstiges Bemerkung
End With
End If
'Blatt "THT_Baut. vorb" C abgleichen - Werte aus Spalten H & K von Alt nach Neu kopieren
Zeile_Alt = 0
Zeile_Diff = 0
vWert_B = 0
Zelle_Wert_B = 0
With wks_VORB_Alt
For Zeile_Alt = 12 To 14:  '  Zeile 12 bis 14 checken
'Wert in Altdatei-Spalte C
vWert_B = .Cells(Zeile_Alt, 3).Value
If vWert_B  "" Then
'Wert in neuer Datei Spalte C suchen
With wks_VORB_Neu
Set Zelle_Wert_B = .Range(.Cells(12, 3), .Cells(14, 3)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole) '  Zeile 12 bis 14 checken Spalte C
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff Is Nothing Then
'Tabellenblatt fuer Abweichungen anlegen
Set wks_diff = wbNeu.Worksheets.Add(After:=wks_VORB_Neu)
wks_diff.Name = "Diff1-Vorb"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
If .Cells(Zeile_Alt, 8)  "" Then
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff.Cells(Zeile_Diff, 1)
End If
Else
'Werte aus Spalten H von Alt nach Neu kopieren wenn nicht gesperrt ist
If .Cells(Zeile_Alt, 8).AllowEdit = False Then
Else
.Cells(Zeile_Alt, 8).Copy _
Destination:=wks_VORB_Neu.Cells(Zelle_Wert_B.Row, 8)
End If
'Werte aus Spalte K von Alt nach Neu kopieren
.Cells(Zeile_Alt, 11).Copy _
Destination:=wks_VORB_Neu.Cells(Zelle_Wert_B.Row, 11)
End If
End If
Next
End With
'Blatt "THT_Baut. vorb" B abgleichen - Werte aus Spalten H & K von Alt nach Neu kopieren
Zeile_Alt = 0
Zeile_Diff = 0
vWert_B = 0
Zelle_Wert_B = 0
With wks_VORB_Alt
For Zeile_Alt = 16 To 33:  '  Zeile 16 bis 33 checken
'Wert in Altdatei-Spalte A
vWert_B = .Cells(Zeile_Alt, 1).Value
If vWert_B  "" Then
'Wert in neuer Datei Spalte A suchen
With wks_VORB_Neu
Set Zelle_Wert_B = .Range(.Cells(16, 1), .Cells(33, 1)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole) '  Zeile 16 bis 33 checken Spalte A
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff1 Is Nothing Then
'Tabellenblatt fuer Abweichungen anlegen
Set wks_diff1 = wbNeu.Worksheets.Add(After:=wks_VORB_Neu)
wks_diff1.Name = "Diff2-VORB"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff1.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
If .Cells(Zeile_Alt, 8)  "" Then
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff1.Cells(Zeile_Diff, 1)
End If
Else
'Werte aus Spalten H von Alt nach Neu kopieren wenn nicht gesperrt ist
If .Cells(Zeile_Alt, 8).AllowEdit = False Then
Else
.Cells(Zeile_Alt, 8).Copy _
Destination:=wks_VORB_Neu.Cells(Zelle_Wert_B.Row, 8)
End If
'Werte aus Spalte K von Alt nach Neu kopieren
.Cells(Zeile_Alt, 11).Copy _
Destination:=wks_VORB_Neu.Cells(Zelle_Wert_B.Row, 11)
End If
End If
Next
End With
'Kopieren von Standard Daten (gleicher Inhalt A)
' VORB
With wbAlt.Worksheets("THT_Baut. vorb")
.Range("H18").Copy Destination:=wbNeu.Worksheets(.Name).Range("H18") 'CO36
.Range("M18:N18").Copy Destination:=wbNeu.Worksheets(.Name).Range("M18:N18") 'CO36 Bemerkung
.Range("H20").Copy Destination:=wbNeu.Worksheets(.Name).Range("H20") 'Hand
.Range("M20:N20").Copy Destination:=wbNeu.Worksheets(.Name).Range("M20:N20") 'Hand Bemerkung
End With
'Blatt "THT_Leit. vorm" B abgleichen - Werte aus Spalten I & L von Alt nach Neu kopieren
Zeile_Alt = 0
Zeile_Diff = 0
vWert_B = 0
Zelle_Wert_B = 0
With wks_VORM_Alt
For Zeile_Alt = 13 To 99
'Wert in Altdatei-Spalte B
vWert_B = .Cells(Zeile_Alt, 2).Value
If vWert_B  "" Then
'Wert in neuer Datei Spalte B suchen
With wks_VORM_Neu
Set Zelle_Wert_B = .Range(.Cells(13, 2), .Cells(99, 2)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole) '  Zeile 13 bis 99 checken Spalte B
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff2 Is Nothing Then
'Tabellenblatt fuer Abweichungen anlegen
Set wks_diff2 = wbNeu.Worksheets.Add(After:=wks_VORM_Neu)
wks_diff2.Name = "Diff-VORM"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff2.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
If .Cells(Zeile_Alt, 9)  "" Then
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff2.Cells(Zeile_Diff, 1)
End If
Else
'Werte aus Spalten I von Alt nach Neu kopieren wenn nicht gesperrt ist
If .Cells(Zeile_Alt, 9).AllowEdit = False Then
Else
.Cells(Zeile_Alt, 9).Copy _
Destination:=wks_VORM_Neu.Cells(Zelle_Wert_B.Row, 9)
End If
'Werte aus Spalten L von Alt nach Neu kopieren
.Cells(Zeile_Alt, 12).Copy _
Destination:=wks_VORM_Neu.Cells(Zelle_Wert_B.Row, 12)
End If
End If
Next
End With
'Nutzen
wbAlt.Worksheets("THT_Leit. vorm").Range("C7").Copy
wbNeu.Worksheets("THT_Leit. vorm").Range("C7").PasteSpecial Paste:=xlValues 'Nutzen
'Kopieren von Standard Daten (Zelle I13)
' VORM
With wbAlt.Worksheets("THT_Leit. vorm")
.Range("I13").Copy Destination:=wbNeu.Worksheets(.Name).Range("I13") 'Nietabstaende
'Kopieren von Standard Daten (Zelle F50 oder F48 je nach Version der Vorlage)
If wbAlt.VORM.Range("A34") = "4.Kuehlkoerpermontage" Then
.Range("F50").Copy Destination:=wbNeu.Worksheets(.Name).Range("F50") 'KK sonstiges
Else
End If
If wbAlt.VORM.Range("A32") = "4.Kuehlkoerpermontage" Then
.Range("F48").Copy Destination:=wbNeu.Worksheets(.Name).Range("F50") 'KK sonstiges
Else
End If
End With
'Blatt "PRESS" B abgleichen - Werte aus Spalten H & L von Alt nach Neu kopieren
Zeile_Alt = 0
Zeile_Diff = 0
vWert_B = 0
Zelle_Wert_B = 0
With wks_PRESS_Alt
For Zeile_Alt = 13 To 32
'Wert in Altdatei-Spalte B
vWert_B = .Cells(Zeile_Alt, 2).Value
If vWert_B  "" Then
'Wert in neuer Datei Spalte B suchen
With wks_PRESS_Neu
Set Zelle_Wert_B = .Range(.Cells(13, 2), .Cells(32, 2)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole) '  Zeile 13 bis 32 checken Spalte B
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff4 Is Nothing Then
'Tabellenblatt fuer Abweichungen anlegen
Set wks_diff4 = wbNeu.Worksheets.Add(After:=wks_PRESS_Neu)
wks_diff4.Name = "Diff-PRESS"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff4.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
If .Cells(Zeile_Alt, 8)  "" Then
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff4.Cells(Zeile_Diff, 1)
End If
Else
'Werte aus Spalten H von Alt nach Neu kopieren wenn nicht gesperrt ist
If .Cells(Zeile_Alt, 8).AllowEdit = False Then
Else
.Cells(Zeile_Alt, 8).Copy _
Destination:=wks_PRESS_Neu.Cells(Zelle_Wert_B.Row, 8)
End If
'Werte aus Spalten L von Alt nach Neu kopieren
.Cells(Zeile_Alt, 12).Copy _
Destination:=wks_PRESS_Neu.Cells(Zelle_Wert_B.Row, 12)
End If
End If
Next
End With
'Nutzen
wbAlt.Worksheets("THT_Einpresst.").Range("D7").Copy
wbNeu.Worksheets("THT_Einpresst.").Range("D7").PasteSpecial Paste:=xlValues 'Nutzen
'Blatt "FERT1" B abgleichen - Werte aus Spalten H & L:M von Alt nach Neu kopieren
Zeile_Alt = 0
Zeile_Diff = 0
vWert_B = 0
Zelle_Wert_B = 0
With wks_FERT1_Alt
For Zeile_Alt = 12 To 152
'Wert in Altdatei-Spalte B
vWert_B = .Cells(Zeile_Alt, 2).Value
If vWert_B  "" Then
'Wert in neuer Datei Spalte B suchen
With wks_FERT1_Neu
Set Zelle_Wert_B = .Range(.Cells(12, 2), .Cells(152, 2)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole) '  Zeile 12 bis 152 checken Spalte B
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff5 Is Nothing Then
'Tabellenblatt fuer Abweichungen anlegen
Set wks_diff5 = wbNeu.Worksheets.Add(After:=wks_FERT1_Neu)
wks_diff5.Name = "Diff-FERT1"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff5.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
If .Cells(Zeile_Alt, 8)  "" Then
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff5.Cells(Zeile_Diff, 1)
End If
Else
'Werte aus Spalten H von Alt nach Neu kopieren wenn nicht gesperrt ist
If .Cells(Zeile_Alt, 8).AllowEdit = False Then
Else
.Cells(Zeile_Alt, 8).Copy _
Destination:=wks_FERT1_Neu.Cells(Zelle_Wert_B.Row, 8)
End If
'Werte aus Spalten L:M von Alt nach Neu kopieren
.Range(.Cells(Zeile_Alt, 12), .Cells(Zeile_Alt, 13)).Copy _
Destination:=wks_FERT1_Neu.Cells(Zelle_Wert_B.Row, 12)
End If
End If
Next
End With
'Nutzen
wbAlt.Worksheets("THT_Fert.mont_1").Range("C7").Copy
wbNeu.Worksheets("THT_Fert.mont_1").Range("C7").PasteSpecial Paste:=xlValues 'Nutzen
wbAlt.Worksheets("THT_Fert.mont_1").Range("H63").Copy
wbNeu.Worksheets("THT_Fert.mont_1").Range("H63").PasteSpecial Paste:=xlValues 'Nietabstaende (Text auf Spalte A)
wbAlt.Worksheets("THT_Fert.mont_1").Range("H107").Copy
wbNeu.Worksheets("THT_Fert.mont_1").Range("H107").PasteSpecial Paste:=xlValues 'Trennen ohne TXT in Spalte B
wbAlt.Worksheets("THT_Fert.mont_1").Range("H108").Copy
wbNeu.Worksheets("THT_Fert.mont_1").Range("H108").PasteSpecial Paste:=xlValues 'Trennen ohne TXT in Spalte B
'Blatt "FERT2" B abgleichen - Werte aus Spalten H & L:M von Alt nach Neu kopieren
Zeile_Alt = 0
Zeile_Diff = 0
vWert_B = 0
Zelle_Wert_B = 0
With wks_FERT2_Alt
For Zeile_Alt = 12 To 152
'Wert in Altdatei-Spalte B
vWert_B = .Cells(Zeile_Alt, 2).Value
If vWert_B  "" Then
'Wert in neuer Datei Spalte B suchen
With wks_FERT2_Neu
Set Zelle_Wert_B = .Range(.Cells(12, 2), .Cells(152, 2)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole) '  Zeile 12 bis 152 checken Spalte B
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff6 Is Nothing Then
'Tabellenblatt fuer Abweichungen anlegen
Set wks_diff6 = wbNeu.Worksheets.Add(After:=wks_FERT2_Neu)
wks_diff6.Name = "Diff-FERT2"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff6.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
If .Cells(Zeile_Alt, 8)  "" Then
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff6.Cells(Zeile_Diff, 1)
Else
End If
Else
'Werte aus Spalten H von Alt nach Neu kopieren wenn nicht gesperrt ist
If .Cells(Zeile_Alt, 8).AllowEdit = False Then
Else
.Cells(Zeile_Alt, 8).Copy _
Destination:=wks_FERT2_Neu.Cells(Zelle_Wert_B.Row, 8)
End If
'Werte aus Spalten L:M von Alt nach Neu kopieren
.Range(.Cells(Zeile_Alt, 12), .Cells(Zeile_Alt, 13)).Copy _
Destination:=wks_FERT2_Neu.Cells(Zelle_Wert_B.Row, 12)
End If
End If
Next
End With
'Nutzen
wbAlt.Worksheets("THT_Fert.mont_2").Range("C7").Copy
wbNeu.Worksheets("THT_Fert.mont_2").Range("C7").PasteSpecial Paste:=xlValues 'Nutzen
wbAlt.Worksheets("THT_Fert.mont_1").Range("H63").Copy
wbNeu.Worksheets("THT_Fert.mont_2").Range("H63").PasteSpecial Paste:=xlValues 'Nietabstaende (Text auf Spalte A)
wbAlt.Worksheets("THT_Fert.mont_2").Range("H107").Copy
wbNeu.Worksheets("THT_Fert.mont_2").Range("H107").PasteSpecial Paste:=xlValues 'Trennen ohne TXT in Spalte B
wbAlt.Worksheets("THT_Fert.mont_2").Range("H108").Copy
wbNeu.Worksheets("THT_Fert.mont_2").Range("H108").PasteSpecial Paste:=xlValues 'Trennen ohne TXT in Spalte B
'Blatt "FERT3" B abgleichen - Werte aus Spalten H & L:M von Alt nach Neu kopieren
Zeile_Alt = 0
Zeile_Diff = 0
vWert_B = 0
Zelle_Wert_B = 0
With wks_FERT3_Alt
For Zeile_Alt = 12 To 152
'Wert in Altdatei-Spalte B
vWert_B = .Cells(Zeile_Alt, 2).Value
If vWert_B  "" Then
'Wert in neuer Datei Spalte B suchen
With wks_FERT3_Neu
Set Zelle_Wert_B = .Range(.Cells(12, 2), .Cells(152, 2)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole) '  Zeile 12 bis 152 checken Spalte B
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff7 Is Nothing Then
'Tabellenblatt fuer Abweichungen anlegen
Set wks_diff7 = wbNeu.Worksheets.Add(After:=wks_FERT3_Neu)
wks_diff7.Name = "Diff-FERT3"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff7.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
If .Cells(Zeile_Alt, 8)  "" Then
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff7.Cells(Zeile_Diff, 1)
End If
Else
'Werte aus Spalten H von Alt nach Neu kopieren wenn nicht gesperrt ist
If .Cells(Zeile_Alt, 8).AllowEdit = False Then
Else
.Cells(Zeile_Alt, 8).Copy _
Destination:=wks_FERT3_Neu.Cells(Zelle_Wert_B.Row, 8)
End If
'Werte aus Spalten L:M von Alt nach Neu kopieren
.Range(.Cells(Zeile_Alt, 12), .Cells(Zeile_Alt, 13)).Copy _
Destination:=wks_FERT3_Neu.Cells(Zelle_Wert_B.Row, 12)
End If
End If
Next
End With
'Nutzen
wbAlt.Worksheets("THT_Fert.mont_3").Range("C7").Copy
wbNeu.Worksheets("THT_Fert.mont_3").Range("C7").PasteSpecial Paste:=xlValues 'Nutzen
wbAlt.Worksheets("THT_Fert.mont_1").Range("H63").Copy
wbNeu.Worksheets("THT_Fert.mont_3").Range("H63").PasteSpecial Paste:=xlValues 'Nietabstaende (Text auf Spalte A)
wbAlt.Worksheets("THT_Fert.mont_3").Range("H107").Copy
wbNeu.Worksheets("THT_Fert.mont_3").Range("H107").PasteSpecial Paste:=xlValues 'Trennen ohne TXT in Spalte B
wbAlt.Worksheets("THT_Fert.mont_3").Range("H108").Copy
wbNeu.Worksheets("THT_Fert.mont_3").Range("H108").PasteSpecial Paste:=xlValues 'Trennen ohne TXT in Spalte B
'Nicht immer vorhandene Tabellenblaetter Teil 2
'Abfrage ob Tabellenblatt Fertigungsinsel in Alt vorhanden ist
On Error Resume Next
Set wks_INSEL_Alt = wbAlt.Worksheets("Fertigungsinsel")
If Err.Number = 0 Then
'Wenn kein Fehler dann
With wks_INSEL_Alt
For Zeile_Alt = 14 To 198
'Wert in Altdatei-Spalte B
vWert_B = .Cells(Zeile_Alt, 2).Value
If vWert_B  "" Then
'Wert in neuer Datei Spalte B suchen
With wks_INSEL_Neu
Set Zelle_Wert_B = .Range(.Cells(14, 2), .Cells(198, 2)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole) '  Zeile 14 bis 198 checken Spalte B
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff9 Is Nothing Then
'Tabellenblatt fuer Abweichungen anlegen
Set wks_diff9 = wbNeu.Worksheets.Add(After:=wks_INSEL_Neu)
wks_diff9.Name = "Diff-INSEL"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff9.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
If .Cells(Zeile_Alt, 8)  "" Then
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff9.Cells(Zeile_Diff, 1)
End If
Else
'Werte aus Spalten H von Alt nach Neu kopieren wenn nicht gesperrt ist
If .Cells(Zeile_Alt, 8).AllowEdit = False Then
Else
.Cells(Zeile_Alt, 8).Copy _
Destination:=wks_INSEL_Neu.Cells(Zelle_Wert_B.Row, 8)
End If
'Werte aus Spalten L:M von Alt nach Neu kopieren
.Range(.Cells(Zeile_Alt, 12), .Cells(Zeile_Alt, 13)).Copy _
Destination:=wks_INSEL_Neu.Cells(Zelle_Wert_B.Row, 12)
End If
End If
Next
'Standartwerte
.Range("C9").Copy wbNeu.Worksheets(.Name).Range("C7") 'Nutzen
.Range("H94").Copy wbNeu.Worksheets(.Name).Range("H94") 'Nietabstaende
.Range("H138").Copy wbNeu.Worksheets(.Name).Range("H138") 'Nietabstaende
.Range("H139").Copy wbNeu.Worksheets(.Name).Range("H139") 'Nietabstaende
End With
Else
MsgBox "Keine Fertigungsinsel im alten Kalk Tool."
End If
'Nicht immer vorhandene Tabellenblaetter Teil 3
'Abfrage ob Tabellenblatt Pruefen in Alt vorhanden ist
On Error Resume Next
If Umlaute = 1 Then
Set wks_PRUEF1_Alt = wbAlt.Worksheets("Pruefen")
Else
Set wks_PRUEF1_Alt = wbAlt.Worksheets("Prüfen")
End If
If Err.Number = 0 Then
'Wenn kein Fehler dann
'Versionspruefung (Ab Version 248 werden die Daten anders uebernommen)
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 248 Then GoTo Versionierung
With wks_PRUEF1_Alt
wbNeu.Worksheets("Pruefen").Range("O59") = .Range("O53").Value + .Range("O61").Value + .Range("O63").Value
.Range("G5:K5").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("G5:K5")
.Range("R2:V2").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("R2:V2")
.Range("R3:V3").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("R3:V3")
.Range("R5:V5").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("R5:V5")
.Range("O34").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("Q34")
.Range("O38:R38").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("O38:R38")
.Range("M40").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("M40")
.Range("O47:R47").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("O47:R47")
.Range("M49").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("M49")
.Range("O63").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("O63")
.Range("O75").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("O75")
.Range("Q75").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("Q75")
.Range("C72:M78").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("C72:M78")
End With
'Pruefen(2)
If Umlaute = 1 Then
Set wks_PRUEF2_Alt = wbAlt.Worksheets("Pruefen 2")
Else
Set wks_PRUEF2_Alt = wbAlt.Worksheets("Prüfen 2")
End If
With wks_PRUEF2_Alt
wbNeu.Worksheets("Pruefen 2").Range("O59") = .Range("O53").Value + .Range("O61").Value + .Range("O63").Value
.Range("G5:K5").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("G5:K5")
.Range("R2:V2").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("R2:V2")
.Range("R3:V3").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("R3:V3")
.Range("R5:V5").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("R5:V5")
.Range("O34").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("Q34")
.Range("O38:R38").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("O38:R38")
.Range("M40").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("M40")
.Range("O47:R47").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("O47:R47")
.Range("M49").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("M49")
.Range("O63").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("O63")
.Range("O75").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("O75")
.Range("Q75").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("Q75")
.Range("C72:M78").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("C72:M78")
End With
'Pruefen(3)
If Umlaute = 1 Then
Set wks_PRUEF3_Alt = wbAlt.Worksheets("Pruefen 3")
Else
Set wks_PRUEF3_Alt = wbAlt.Worksheets("Prüfen 3")
End If
With wks_PRUEF3_Alt
wbNeu.Worksheets("Pruefen 3").Range("O59") = .Range("O53").Value + .Range("O61").Value + .Range("O63").Value
.Range("G5:K5").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("G5:K5")
.Range("R2:V2").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("R2:V2")
.Range("R3:V3").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("R3:V3")
.Range("R5:V5").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("R5:V5")
.Range("O34").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("Q34")
.Range("O38:R38").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("O38:R38")
.Range("M40").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("M40")
.Range("O47:R47").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("O47:R47")
.Range("M49").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("M49")
.Range("O63").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("O63")
.Range("O75").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("O75")
.Range("Q75").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("Q75")
.Range("C72:M78").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("C72:M78")
End With
End With
Else
MsgBox "Keine Pruefung im alten Kalk Tool."
End If
Versionierung:
Rem ab der Versionierung der XLT Vorlage koennen hier die Veraenderungen eingetragen werden !!!
Rem aenderungen zur Version 2.3.5
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 235 Then
'Nutzen
wbAlt.Worksheets("THT_Fert.mont_3").Range("C8").Copy
wbNeu.Worksheets("THT_Fert.mont_3").Range("C8").PasteSpecial Paste:=xlValues 'Nutzen
Rem aenderung THT_Leit. vorm (Bruchstellen, Anbindung hinzu)
Set wks_VORM_Neu = wbAlt.Worksheets("THT_Leit. vorm")
Else
End If
End With
'aenderungen zur Version 2.3.8
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 238 Then
Rem aenderung an der Bauteilvorbereitung
Set wks_VORB_Alt = wbAlt.Worksheets("THT_Baut. vorb")
With wks_VORB_Alt
.Range("H36").Copy Destination:=wbNeu.Worksheets(.Name).Range("H36")
.Range("K36").Copy Destination:=wbNeu.Worksheets(.Name).Range("K36")
.Range("H39").Copy Destination:=wbNeu.Worksheets(.Name).Range("H39")
.Range("K39").Copy Destination:=wbNeu.Worksheets(.Name).Range("K39")
.Range("H41").Copy Destination:=wbNeu.Worksheets(.Name).Range("H41")
.Range("K41").Copy Destination:=wbNeu.Worksheets(.Name).Range("K41")
.Range("H43").Copy Destination:=wbNeu.Worksheets(.Name).Range("H43")
.Range("K43").Copy Destination:=wbNeu.Worksheets(.Name).Range("K43")
.Range("H46").Copy Destination:=wbNeu.Worksheets(.Name).Range("H46")
.Range("K46").Copy Destination:=wbNeu.Worksheets(.Name).Range("K46")
End With
Else
End If
End With
'aenderungen zur Version 2.3.9
Rem Blatt Fertigmontage 1
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 239 Then
Rem aenderungsdraht mit Knicke koennen angegeben werden
Set wks_FERT1_Alt = wbAlt.Worksheets("THT_Fert.mont_1")
With wks_FERT1_Alt
.Range("D87").Copy Destination:=wbNeu.Worksheets(.Name).Range("D87")
.Range("I158").Copy Destination:=wbNeu.Worksheets(.Name).Range("I158")
.Range("I160").Copy Destination:=wbNeu.Worksheets(.Name).Range("I160")
.Range("I162").Copy Destination:=wbNeu.Worksheets(.Name).Range("I162")
.Range("I164").Copy Destination:=wbNeu.Worksheets(.Name).Range("I164")
.Range("I166").Copy Destination:=wbNeu.Worksheets(.Name).Range("I166")
.Range("I168").Copy Destination:=wbNeu.Worksheets(.Name).Range("I168")
.Range("I170").Copy Destination:=wbNeu.Worksheets(.Name).Range("I170")
.Range("I172").Copy Destination:=wbNeu.Worksheets(.Name).Range("I172")
.Range("I174").Copy Destination:=wbNeu.Worksheets(.Name).Range("I174")
.Range("I176").Copy Destination:=wbNeu.Worksheets(.Name).Range("I176")
.Range("L158:L176").Copy Destination:=wbNeu.Worksheets(.Name).Range("L158:L176")
End With
Else
End If
End With
Rem Blatt Fertigmontage 2
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 239 Then
Rem aenderungsdraht mit Knicke koennen angegeben werden
Set wks_FERT2_Alt = wbAlt.Worksheets("THT_Fert.mont_2")
With wks_FERT2_Alt
.Range("D87").Copy Destination:=wbNeu.Worksheets(.Name).Range("D87")
.Range("I158").Copy Destination:=wbNeu.Worksheets(.Name).Range("I158")
.Range("I160").Copy Destination:=wbNeu.Worksheets(.Name).Range("I160")
.Range("I162").Copy Destination:=wbNeu.Worksheets(.Name).Range("I162")
.Range("I164").Copy Destination:=wbNeu.Worksheets(.Name).Range("I164")
.Range("I166").Copy Destination:=wbNeu.Worksheets(.Name).Range("I166")
.Range("I168").Copy Destination:=wbNeu.Worksheets(.Name).Range("I168")
.Range("I170").Copy Destination:=wbNeu.Worksheets(.Name).Range("I170")
.Range("I172").Copy Destination:=wbNeu.Worksheets(.Name).Range("I172")
.Range("I174").Copy Destination:=wbNeu.Worksheets(.Name).Range("I174")
.Range("I176").Copy Destination:=wbNeu.Worksheets(.Name).Range("I176")
.Range("L158:L176").Copy Destination:=wbNeu.Worksheets(.Name).Range("L158:L176")
End With
Else
End If
End With
Rem Blatt Fertigmontage 3
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 239 Then
Rem aenderungsdraht mit Knicke koennen angegeben werden
Set wks_FERT3_Alt = wbAlt.Worksheets("THT_Fert.mont_3")
With wks_FERT3_Alt
.Range("D87").Copy Destination:=wbNeu.Worksheets(.Name).Range("D87")
.Range("I158").Copy Destination:=wbNeu.Worksheets(.Name).Range("I158")
.Range("I160").Copy Destination:=wbNeu.Worksheets(.Name).Range("I160")
.Range("I162").Copy Destination:=wbNeu.Worksheets(.Name).Range("I162")
.Range("I164").Copy Destination:=wbNeu.Worksheets(.Name).Range("I164")
.Range("I166").Copy Destination:=wbNeu.Worksheets(.Name).Range("I166")
.Range("I168").Copy Destination:=wbNeu.Worksheets(.Name).Range("I168")
.Range("I170").Copy Destination:=wbNeu.Worksheets(.Name).Range("I170")
.Range("I172").Copy Destination:=wbNeu.Worksheets(.Name).Range("I172")
.Range("I174").Copy Destination:=wbNeu.Worksheets(.Name).Range("I174")
.Range("I176").Copy Destination:=wbNeu.Worksheets(.Name).Range("I176")
.Range("L158:L176").Copy Destination:=wbNeu.Worksheets(.Name).Range("L158:L176")
End With
Else
End If
End With
Rem Blatt Fertigungsinsel
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 239 Then
Rem aenderungsdraht mit Knicke koennen angegeben werden
Set wks_INSEL_Alt = wbAlt.Worksheets("Fertigungsinsel")
With wks_INSEL_Alt
.Range("D118").Copy Destination:=wbNeu.Worksheets(.Name).Range("D118")
.Range("H203").Copy Destination:=wbNeu.Worksheets(.Name).Range("H203")
.Range("H205").Copy Destination:=wbNeu.Worksheets(.Name).Range("H205")
.Range("H207").Copy Destination:=wbNeu.Worksheets(.Name).Range("H207")
.Range("H209").Copy Destination:=wbNeu.Worksheets(.Name).Range("H209")
.Range("H211").Copy Destination:=wbNeu.Worksheets(.Name).Range("H211")
.Range("H213").Copy Destination:=wbNeu.Worksheets(.Name).Range("H213")
.Range("H215").Copy Destination:=wbNeu.Worksheets(.Name).Range("H215")
.Range("H217").Copy Destination:=wbNeu.Worksheets(.Name).Range("H217")
.Range("H219").Copy Destination:=wbNeu.Worksheets(.Name).Range("H219")
.Range("H221").Copy Destination:=wbNeu.Worksheets(.Name).Range("H221")
.Range("L158:L176").Copy Destination:=wbNeu.Worksheets(.Name).Range("H203:H221")
End With
Else
End If
End With
Rem Blatt Vormontage
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 239 Then
Rem aenderungsdraht mit Knicke koennen angegeben werden
Set wks_VORM_Alt = wbAlt.Worksheets("THT_Leit. vorm")
With wks_VORM_Alt
.Range("I105").Copy Destination:=wbNeu.Worksheets(.Name).Range("I105")
.Range("I107").Copy Destination:=wbNeu.Worksheets(.Name).Range("I107")
.Range("I109").Copy Destination:=wbNeu.Worksheets(.Name).Range("I109")
.Range("I111").Copy Destination:=wbNeu.Worksheets(.Name).Range("I111")
.Range("I113").Copy Destination:=wbNeu.Worksheets(.Name).Range("I113")
.Range("I115").Copy Destination:=wbNeu.Worksheets(.Name).Range("I115")
.Range("I121").Copy Destination:=wbNeu.Worksheets(.Name).Range("I121")
.Range("I123").Copy Destination:=wbNeu.Worksheets(.Name).Range("I123")
.Range("L158:L176").Copy Destination:=wbNeu.Worksheets(.Name).Range("L105:L123")
End With
Else
End If
End With
'Aenderungen zur Version 2.4.8
Rem 3x Pruefblaetter
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 248 Then
With wks_PRUEF1_Alt
.Range("G5:K5").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("G5:K5")
.Range("R2:V2").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("R2:V2")
.Range("R3:V3").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("R3:V3")
.Range("R5:V5").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("R5:V5")
.Range("Q34").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("Q34")
.Range("O38:R38").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("O38:R38")
.Range("M40").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("M40")
.Range("O47:R47").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("O47:R47")
.Range("M49").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("M49")
.Range("O59").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("O59")
.Range("O63").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("O63")
.Range("O75").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("O75")
.Range("Q75").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("Q75")
.Range("C72:M78").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("C72:M78")
End With
'Pruefen(2)
If Umlaute = 1 Then
Set wks_PRUEF2_Alt = wbAlt.Worksheets("Pruefen 2")
Else
Set wks_PRUEF2_Alt = wbAlt.Worksheets("Prüfen 2")
End If
With wks_PRUEF2_Alt
.Range("G5:K5").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("G5:K5")
.Range("R2:V2").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("R2:V2")
.Range("R3:V3").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("R3:V3")
.Range("R5:V5").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("R5:V5")
.Range("Q34").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("Q34")
.Range("O38:R38").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("O38:R38")
.Range("M40").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("M40")
.Range("O47:R47").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("O47:R47")
.Range("M49").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("M49")
.Range("O59").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("O59")
.Range("O63").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("O63")
.Range("O75").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("O75")
.Range("Q75").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("Q75")
.Range("C72:M78").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("C72:M78")
End With
'Pruefen(3)
If Umlaute = 1 Then
Set wks_PRUEF3_Alt = wbAlt.Worksheets("Pruefen 3")
Else
Set wks_PRUEF3_Alt = wbAlt.Worksheets("Prüfen 3")
End If
With wks_PRUEF3_Alt
.Range("G5:K5").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("G5:K5")
.Range("R2:V2").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("R2:V2")
.Range("R3:V3").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("R3:V3")
.Range("R5:V5").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("R5:V5")
.Range("Q34").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("Q34")
.Range("O38:R38").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("O38:R38")
.Range("M40").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("M40")
.Range("O47:R47").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("O47:R47")
.Range("M49").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("M49")
.Range("O59").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("O59")
.Range("O63").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("O63")
.Range("O75").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("O75")
.Range("Q75").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("Q75")
.Range("C72:M78").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("C72:M78")
End With
Else
End If
End With
'Aenderungen zur Version 2.5.4
'Bestuecken am Band wurde an das neue Senden Tool angepasst mit der Moeglichkeit diese direkt per copy und paste zu uebertragen
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 254 Then
'Tabellenblaetter Pruefung
If Umlaute = 1 Then
Set wks_PRUEF1_Alt = wbAlt.Worksheets("Pruefen")
Else
Set wks_PRUEF1_Alt = wbAlt.Worksheets("Prüfen")
End If
With wks_PRUEF1_Alt 'Pruefen(1)
.Range("H69").Copy Destination:=wbNeu.Worksheets("Pruefen").Range("H69")
End With
If Umlaute = 1 Then
Set wks_PRUEF2_Alt = wbAlt.Worksheets("Pruefen 2")
Else
Set wks_PRUEF2_Alt = wbAlt.Worksheets("Prüfen 2")
End If
With wks_PRUEF2_Alt 'Pruefen(2)
.Range("H69").Copy Destination:=wbNeu.Worksheets("Pruefen 2").Range("H69")
End With
If Umlaute = 1 Then
Set wks_PRUEF3_Alt = wbAlt.Worksheets("Pruefen 3")
Else
Set wks_PRUEF3_Alt = wbAlt.Worksheets("Prüfen 3")
End If
With wks_PRUEF3_Alt 'Pruefen(3)
.Range("H69").Copy Destination:=wbNeu.Worksheets("Pruefen 3").Range("H69")
End With
'Tabellenblatt Handbestueckung
'Nutzen
wbAlt.Worksheets("THT-Handbest.").Range("C5").Copy
wbNeu.Worksheets("THT-Handbest.").Range("C5").PasteSpecial Paste:=xlValues 'Nutzen
Set wks_HAND_Alt = wbAlt.Worksheets("THT-Handbest.")
With wks_HAND_Alt
.Range("J9:K32").Copy Destination:=wbNeu.Worksheets(.Name).Range("J9:K32") 'Bemerkung
.Range("N8:X69").Copy Destination:=wbNeu.Worksheets(.Name).Range("N8:X69") 'THT Bauteile
.Range("Z9:Z69").Copy Destination:=wbNeu.Worksheets(.Name).Range("Z9:Z69") 'THT Bauteile / Formeln
.Range("F27").Copy Destination:=wbNeu.Worksheets(.Name).Range("F27") 'Kisten
.Range("F30").Copy Destination:=wbNeu.Worksheets(.Name).Range("F30") ' Vorrichtungen
.Range("F38").Copy Destination:=wbNeu.Worksheets(.Name).Range("F38") ' Anzahl Nutzen pro Loetrahmen
.Range("F40").Copy Destination:=wbNeu.Worksheets(.Name).Range("F40") ' Anzahl Loetrahmen
End With
Else
'Vorlage Kalkulation nach dem altem Verfahren
wbAlt.Worksheets("THT-Handbest.").Range("C8").Copy
wbNeu.Worksheets("THT-Handbest.").Range("C5").PasteSpecial Paste:=xlValues 'Nutzen
Set wks_HAND_Alt = wbAlt.Worksheets("THT-Handbest.")
With wks_HAND_Alt
.Range("J13").Copy Destination:=wbNeu.Worksheets(.Name).Range("J9") 'Bemerkung Format
.Range("J15").Copy Destination:=wbNeu.Worksheets(.Name).Range("J10") 'Bemerkung Format
.Range("J17").Copy Destination:=wbNeu.Worksheets(.Name).Range("J11") 'Bemerkung Format
.Range("J19").Copy Destination:=wbNeu.Worksheets(.Name).Range("J12") 'Bemerkung Format
.Range("J21").Copy Destination:=wbNeu.Worksheets(.Name).Range("J13") 'Bemerkung Format
.Range("J23").Copy Destination:=wbNeu.Worksheets(.Name).Range("J14") 'Bemerkung Format
.Range("J23").Copy Destination:=wbNeu.Worksheets(.Name).Range("J14") 'Bemerkung Format
.Range("F45").Copy Destination:=wbNeu.Worksheets(.Name).Range("F27") 'Kisten
.Range("F51").Copy Destination:=wbNeu.Worksheets(.Name).Range("F30") ' Vorrichtungen
.Range("J45").Copy Destination:=wbNeu.Worksheets(.Name).Range("J27") 'Kisten Bemerkung
.Range("J51").Copy Destination:=wbNeu.Worksheets(.Name).Range("J30") ' Vorrichtungen Bemerkung
MsgBox "Verfuegbare Schwallrahmen pflegen / fill the available frames "
End With
MsgBox "Bitte THT Handbestueckung neu berechnen / Please fill sheet THT hand assembly new"
End If
End With
'Aenderungen zur Version 2.5.5
'AOI Tabellenblatt wurde mit Version 255 eingefuehrt
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 255 Then
'Tabellenblaetter Pruefung
Set wks_AOI_Alt = wbAlt.Worksheets("AOI")
With wks_AOI_Alt
.Range("D9").Copy Destination:=wbNeu.Worksheets(.Name).Range("D9")
.Range("D10").Copy Destination:=wbNeu.Worksheets(.Name).Range("D10")
.Range("F9").Copy Destination:=wbNeu.Worksheets(.Name).Range("F9")
.Range("F10").Copy Destination:=wbNeu.Worksheets(.Name).Range("F10")
End With
End If
End With
Call Version265(wbAlt, wbNeu)
Call Version266(wbAlt, wbNeu)
Call Version269(wbAlt, wbNeu)
Call Version270(wbAlt, wbNeu)
'Altdatei wieder schliessen
wbAlt.Close SaveChanges:=False
'Makrobremsen zuruecksetzen
With Application
.EnableEvents = True
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
Rem Info Statusbar
Dim sText As String
Application.StatusBar = False
For Each wks In ActiveWorkbook.Worksheets
If Left(wks.Name, 4) = "Diff" Then
ThisWorkbook.Worksheets(wks.Name).Tab.Color = 250
If sText = "" Then
sText = wks.Name
Else
sText = sText & ", " & wks.Name
End If
End If
Next wks
If sText  "" Then
Application.StatusBar = "Bitte die Tabellen  " & sText & "  checken und danach loeschen."
End If
' uebergabeprotokoll alt sichern
Sheets("Uebergabeprotokoll").Select
ActiveWindow.SmallScroll ToRight:=-6
Range("B4:CI4").Select
Selection.Copy
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Sheet Grunddaten auswaehlen
Sheets("Grunddaten").Select
Rem  Formatierung anpassen
Range("E7,I7").Select
Range("I7").Activate
Selection.Interior.ColorIndex = 34
Range("E7").Select
Selection.NumberFormat = "@"
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Beenden:
'Verknuepfungen loeschen
ActiveWorkbook.BreakLink Name:=Dateiname, Type:=xlExcelLinks
'Alle Tabellenblaetter (Diff oder Tab) die leer sind loeschen
Application.DisplayAlerts = False ' Meldungen aus
For I = ActiveWorkbook.Worksheets.Count To 1 Step -1
If Worksheets(I).Name = "Tab" Or Worksheets(I).Name  "Diff" Then
If IsEmpty(Worksheets(I).UsedRange) Then
Worksheets(I).Delete
End If
End If
Next I
Application.DisplayAlerts = True ' Meldungen wieder einschalten
VBA.ChDir VerzeichnisAktiv 'aktives Verzeichnis zuruecksetzen
Set wbNeu = Nothing: Set wks_Grunddaten_Neu = Nothing: Set wks_T_Neu = Nothing
Set wks_diff = Nothing
Set wbAlt = Nothing: Set wks_Grunddaten_Alt = Nothing: Set wks_T_Alt = Nothing
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
End Sub


'Unterversionen Extra aufgeführt, da Makrogrenze erreicht wurde



Sub Version265(wbAlt, wbNeu)
'Aenderungen zur Version 2.6.5
MsgBox ("Version265")
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 265 Then
Rem (neu Tabellenblatt Taktzeit und AssemblyReport müssen aus Altkalkulationen ab Version 265 übernommen werden)
Set wks_Takt_Alt = wbAlt.Worksheets("Taktzeit")
Set wks_Report_Alt = wbAlt.Worksheets("AssemblyReport")
With wks_Takt_Alt
.Range("A1:K3").Copy Destination:=wbNeu.Worksheets(.Name).Range("A1:K3")
End With
With wks_Report_Alt
.Range("A1:H300").Copy Destination:=wbNeu.Worksheets(.Name).Range("A1:H300")
End With
Else
'Abfrage ob SMD übernommen oder neu gemacht wird
If MsgBox("Wird SMD neu kalkuliert?", vbYesNo) = vbYes Then
Rem keine Aktion notwendig, da die Formel für die Taktzeit auf das neue Taktzeit Tabellenblatt zugreift
Else
'Hier wird die Taktzeit aus der alten Kalkulation geholt und die Formel überschrieben
With wbAlt.Worksheets("SMD-Bestuecken_L")
.Range("F12").Copy Destination:=wbNeu.Worksheets(.Name).Range("F12") 'Bestückzeit
End With
With wbAlt.Worksheets("SMD-Bestuecken_B")
.Range("F12").Copy Destination:=wbNeu.Worksheets(.Name).Range("F12") 'Bestückzeit
End With
With wbAlt.Worksheets("SMD-Ruesten Material")
.Range("F9").Copy Destination:=wbNeu.Worksheets(.Name).Range("F9") 'Ruestpositionen
.Range("H9:I10").Copy Destination:=wbNeu.Worksheets(.Name).Range("H9:I10") 'Bemerkung zu Ruestposition
End With
End If
End If
End With
End Sub




Sub Version266(wbAlt, wbNeu)
'Aenderungen zur Version 2.6.6
MsgBox ("Version266")
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value = 266 Then
'Übernahme der SMD IST Zeiten ist möglich letzte Auswahl Kalkuliert oder ISTZEIT muss geholt werden
'SMD-Bestuecken_L
With wbAlt.Worksheets("SMD-Bestuecken_L")
.Range("I7").Copy Destination:=wbNeu.Worksheets(.Name).Range("J7") 'Kalk oder IST-Zeiten
End With
'SMD-Bestuecken_B
With wbAlt.Worksheets("SMD-Bestuecken_B")
.Range("I7").Copy Destination:=wbNeu.Worksheets(.Name).Range("J7") 'Kalk oder IST-Zeiten
End With
End If
End With
End Sub






Sub Version269(wbAlt, wbNeu)
'Aenderungen zur Version 2.6.9
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 269 Then
'Zeitaufnahmen
With wbAlt.Worksheets("Grunddaten")
.Range("D53:M55").Copy Destination:=wbNeu.Worksheets(.Name).Range("D53:M55")
.Range("D56:N57").Copy Destination:=wbNeu.Worksheets(.Name).Range("D56:N57")
End With
'Weiteres Cluster bei SMD Ist Zeiten eingeführt
'SMD-Bestuecken_L
With wbAlt.Worksheets("SMD-Bestuecken_L")
.Range("J7").Copy Destination:=wbNeu.Worksheets(.Name).Range("J7") 'Kalk oder IST-Zeiten
End With
'SMD-Bestuecken_B
With wbAlt.Worksheets("SMD-Bestuecken_B")
.Range("J7").Copy Destination:=wbNeu.Worksheets(.Name).Range("J7") 'Kalk oder IST-Zeiten
End With
'Neue Selektivlötanlage 01.04.2021
'Selektivanlage
With wbAlt.Worksheets("Selektivloeten")
.Range("C4:C6").Copy Destination:=wbNeu.Worksheets(.Name).Range("C4:C6") 'Nutzen
.Range("J4:J6").Copy Destination:=wbNeu.Worksheets(.Name).Range("J4:J6") 'Nutzen Hinweis
.Range("F12").Copy Destination:=wbNeu.Worksheets(.Name).Range("F12") 'Pins
.Range("G13:G14").Copy Destination:=wbNeu.Worksheets(.Name).Range("G13:G14")
.Range("H15").Copy Destination:=wbNeu.Worksheets(.Name).Range("H15") 'Programmlaufzeit
.Range("J12:J15").Copy Destination:=wbNeu.Worksheets(.Name).Range("J12:J15") 'Bemerkungen
.Range("Y3:Y40").Copy Destination:=wbNeu.Worksheets(.Name).Range("Y3:Y40")
'Parallele Tätigkeiten zur Anlagenzeit
.Range("R19").Copy Destination:=wbNeu.Worksheets(.Name).Range("R19")
.Range("V19").Copy Destination:=wbNeu.Worksheets(.Name).Range("V19")
.Range("W19").Copy Destination:=wbNeu.Worksheets(.Name).Range("W19")
.Range("R24:R25").Copy Destination:=wbNeu.Worksheets(.Name).Range("R24:R25")
.Range("V24:V25").Copy Destination:=wbNeu.Worksheets(.Name).Range("V24:V25")
.Range("W24:W25").Copy Destination:=wbNeu.Worksheets(.Name).Range("W24:W25")
.Range("R28:R31").Copy Destination:=wbNeu.Worksheets(.Name).Range("R28:R31")
.Range("V28:V31").Copy Destination:=wbNeu.Worksheets(.Name).Range("V28:V31")
.Range("W28:W31").Copy Destination:=wbNeu.Worksheets(.Name).Range("W28:W31")
.Range("R34:R48").Copy Destination:=wbNeu.Worksheets(.Name).Range("R34:R48")
.Range("V34:V48").Copy Destination:=wbNeu.Worksheets(.Name).Range("V34:V48")
.Range("W34:W48").Copy Destination:=wbNeu.Worksheets(.Name).Range("W34:W48")
.Range("R51:R53").Copy Destination:=wbNeu.Worksheets(.Name).Range("R51:R53")
.Range("V51:V53").Copy Destination:=wbNeu.Worksheets(.Name).Range("V51:V53")
.Range("W51:W53").Copy Destination:=wbNeu.Worksheets(.Name).Range("W51:W53")
.Range("R55:R58").Copy Destination:=wbNeu.Worksheets(.Name).Range("R55:R58")
.Range("V55:V58").Copy Destination:=wbNeu.Worksheets(.Name).Range("V55:V58")
.Range("W55:W58").Copy Destination:=wbNeu.Worksheets(.Name).Range("W55:W58")
.Range("R60:R68").Copy Destination:=wbNeu.Worksheets(.Name).Range("R60:R68")
.Range("V60:V68").Copy Destination:=wbNeu.Worksheets(.Name).Range("V60:V68")
.Range("W60:W68").Copy Destination:=wbNeu.Worksheets(.Name).Range("W60:W68")
.Range("N67").Copy Destination:=wbNeu.Worksheets(.Name).Range("N67")
.Range("R70:R93").Copy Destination:=wbNeu.Worksheets(.Name).Range("R70:R93")
.Range("V70:V93").Copy Destination:=wbNeu.Worksheets(.Name).Range("V70:V93")
.Range("W70:W93").Copy Destination:=wbNeu.Worksheets(.Name).Range("W70:W93")
.Range("R96:R97").Copy Destination:=wbNeu.Worksheets(.Name).Range("R96:R97")
.Range("V96:V97").Copy Destination:=wbNeu.Worksheets(.Name).Range("V96:V97")
.Range("W96:W97").Copy Destination:=wbNeu.Worksheets(.Name).Range("W96:W97")
.Range("V106:V110").Copy Destination:=wbNeu.Worksheets(.Name).Range("V106:V109")
.Range("R101").Copy Destination:=wbNeu.Worksheets(.Name).Range("R101")
.Range("V101").Copy Destination:=wbNeu.Worksheets(.Name).Range("V101")
.Range("W101").Copy Destination:=wbNeu.Worksheets(.Name).Range("W101")
.Range("R104").Copy Destination:=wbNeu.Worksheets(.Name).Range("R104")
.Range("V104").Copy Destination:=wbNeu.Worksheets(.Name).Range("V104")
.Range("W104").Copy Destination:=wbNeu.Worksheets(.Name).Range("W104")
'Page2
.Range("AC4:AC6").Copy Destination:=wbNeu.Worksheets(.Name).Range("AC4:AC6") 'Nutzen
.Range("AJ4:AJ6").Copy Destination:=wbNeu.Worksheets(.Name).Range("AJ4:AJ6") 'Nutzen Hinweis
.Range("AF12").Copy Destination:=wbNeu.Worksheets(.Name).Range("AF12") 'Pins
.Range("AG13:AG14").Copy Destination:=wbNeu.Worksheets(.Name).Range("AG13:AG14")
.Range("AH15").Copy Destination:=wbNeu.Worksheets(.Name).Range("AH15") 'Programmlaufzeit
.Range("AJ12:AJ15").Copy Destination:=wbNeu.Worksheets(.Name).Range("AJ12:AJ15") 'Bemerkungen
.Range("AY3:AY40").Copy Destination:=wbNeu.Worksheets(.Name).Range("AY3:AY40")
'Parallele Tätigkeiten zur Anlagenzeit
.Range("AR19").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR19")
.Range("AW19").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW19")
.Range("AV19").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV19")
.Range("AR24:AR25").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR24:AR25")
.Range("AV24:AV25").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV24:AV25")
.Range("AW24:AW25").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW24:AW25")
.Range("AR28:AR31").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR28:AR31")
.Range("AV28:AV31").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV28:AV31")
.Range("AW28:AW31").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW28:AW31")
.Range("AR34:AR48").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR34:AR48")
.Range("AV34:AV48").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV34:AV48")
.Range("AW34:AW48").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW34:AW48")
.Range("AR51:AR53").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR51:AR53")
.Range("AV51:AV53").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV51:AV53")
.Range("AW51:AW53").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW51:AW53")
.Range("AR55:AR58").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR55:AR58")
.Range("AV55:AV58").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV55:AV58")
.Range("AW55:AW58").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW55:AW58")
.Range("AR60:AR68").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR60:AR68")
.Range("AV60:AV68").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV60:AV68")
.Range("AW60:AW68").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW60:AW68")
.Range("AN67").Copy Destination:=wbNeu.Worksheets(.Name).Range("AN67")
.Range("AR70:AR93").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR70:AR93")
.Range("AV70:AV93").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV70:AV93")
.Range("AW70:W93").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW70:AW93")
.Range("AR96:AR97").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR96:AR97")
.Range("AV96:AV97").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV96:AV97")
.Range("AW96:AW97").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW96:AW97")
End With
'Selektivanlage Tavellenblatt 2 (Falls Selektivlöten durch z.B. Waschprozess unterbrochen wird)
With wbAlt.Worksheets("Selektivloeten_2")
.Range("C4:C6").Copy Destination:=wbNeu.Worksheets(.Name).Range("C4:C6") 'Nutzen
.Range("J4:J6").Copy Destination:=wbNeu.Worksheets(.Name).Range("J4:J6") 'Nutzen Hinweis
.Range("F12").Copy Destination:=wbNeu.Worksheets(.Name).Range("F12") 'Pins
.Range("G13:G14").Copy Destination:=wbNeu.Worksheets(.Name).Range("G13:G14")
.Range("H15").Copy Destination:=wbNeu.Worksheets(.Name).Range("H15") 'Programmlaufzeit
.Range("J12:J15").Copy Destination:=wbNeu.Worksheets(.Name).Range("J12:J15") 'Bemerkungen
.Range("Y3:Y40").Copy Destination:=wbNeu.Worksheets(.Name).Range("Y3:Y40")
'Parallele Tätigkeiten zur Anlagenzeit
.Range("R19").Copy Destination:=wbNeu.Worksheets(.Name).Range("R19")
.Range("V19").Copy Destination:=wbNeu.Worksheets(.Name).Range("V19")
.Range("W19").Copy Destination:=wbNeu.Worksheets(.Name).Range("W19")
.Range("R24:R25").Copy Destination:=wbNeu.Worksheets(.Name).Range("R24:R25")
.Range("V24:V25").Copy Destination:=wbNeu.Worksheets(.Name).Range("V24:V25")
.Range("W24:W25").Copy Destination:=wbNeu.Worksheets(.Name).Range("W24:W25")
.Range("R28:R31").Copy Destination:=wbNeu.Worksheets(.Name).Range("R28:R31")
.Range("V28:V31").Copy Destination:=wbNeu.Worksheets(.Name).Range("V28:V31")
.Range("W28:W31").Copy Destination:=wbNeu.Worksheets(.Name).Range("W28:W31")
.Range("R34:R48").Copy Destination:=wbNeu.Worksheets(.Name).Range("R34:R48")
.Range("V34:V48").Copy Destination:=wbNeu.Worksheets(.Name).Range("V34:V48")
.Range("W34:W48").Copy Destination:=wbNeu.Worksheets(.Name).Range("W34:W48")
.Range("R51:R53").Copy Destination:=wbNeu.Worksheets(.Name).Range("R51:R53")
.Range("V51:V53").Copy Destination:=wbNeu.Worksheets(.Name).Range("V51:V53")
.Range("W51:W53").Copy Destination:=wbNeu.Worksheets(.Name).Range("W51:W53")
.Range("R55:R58").Copy Destination:=wbNeu.Worksheets(.Name).Range("R55:R58")
.Range("V55:V58").Copy Destination:=wbNeu.Worksheets(.Name).Range("V55:V58")
.Range("W55:W58").Copy Destination:=wbNeu.Worksheets(.Name).Range("W55:W58")
.Range("R60:R68").Copy Destination:=wbNeu.Worksheets(.Name).Range("R60:R68")
.Range("V60:V68").Copy Destination:=wbNeu.Worksheets(.Name).Range("V60:V68")
.Range("W60:W68").Copy Destination:=wbNeu.Worksheets(.Name).Range("W60:W68")
.Range("N67").Copy Destination:=wbNeu.Worksheets(.Name).Range("N67")
.Range("R70:R93").Copy Destination:=wbNeu.Worksheets(.Name).Range("R70:R93")
.Range("V70:V93").Copy Destination:=wbNeu.Worksheets(.Name).Range("V70:V93")
.Range("W70:W93").Copy Destination:=wbNeu.Worksheets(.Name).Range("W70:W93")
.Range("R96:R97").Copy Destination:=wbNeu.Worksheets(.Name).Range("R96:R97")
.Range("V96:V97").Copy Destination:=wbNeu.Worksheets(.Name).Range("V96:V97")
.Range("W96:W97").Copy Destination:=wbNeu.Worksheets(.Name).Range("W96:W97")
.Range("V106:V110").Copy Destination:=wbNeu.Worksheets(.Name).Range("V106:V109")
.Range("R101").Copy Destination:=wbNeu.Worksheets(.Name).Range("R101")
.Range("V101").Copy Destination:=wbNeu.Worksheets(.Name).Range("V101")
.Range("W101").Copy Destination:=wbNeu.Worksheets(.Name).Range("W101")
.Range("R104").Copy Destination:=wbNeu.Worksheets(.Name).Range("R104")
.Range("V104").Copy Destination:=wbNeu.Worksheets(.Name).Range("V104")
.Range("W104").Copy Destination:=wbNeu.Worksheets(.Name).Range("W104")
'Page2
.Range("AC4:AC6").Copy Destination:=wbNeu.Worksheets(.Name).Range("AC4:AC6") 'Nutzen
.Range("AJ4:AJ6").Copy Destination:=wbNeu.Worksheets(.Name).Range("AJ4:AJ6") 'Nutzen Hinweis
.Range("AF12").Copy Destination:=wbNeu.Worksheets(.Name).Range("AF12") 'Pins
.Range("AG13:AG14").Copy Destination:=wbNeu.Worksheets(.Name).Range("AG13:AG14")
.Range("AH15").Copy Destination:=wbNeu.Worksheets(.Name).Range("AH15") 'Programmlaufzeit
.Range("AJ12:AJ15").Copy Destination:=wbNeu.Worksheets(.Name).Range("AJ12:AJ15") 'Bemerkungen
.Range("AY3:AY40").Copy Destination:=wbNeu.Worksheets(.Name).Range("AY3:AY40")
'Parallele Tätigkeiten zur Anlagenzeit
.Range("AR19").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR19")
.Range("AW19").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW19")
.Range("AV19").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV19")
.Range("AR24:AR25").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR24:AR25")
.Range("AV24:AV25").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV24:AV25")
.Range("AW24:AW25").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW24:AW25")
.Range("AR28:AR31").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR28:AR31")
.Range("AV28:AV31").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV28:AV31")
.Range("AW28:AW31").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW28:AW31")
.Range("AR34:AR48").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR34:AR48")
.Range("AV34:AV48").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV34:AV48")
.Range("AW34:AW48").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW34:AW48")
.Range("AR51:AR53").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR51:AR53")
.Range("AV51:AV53").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV51:AV53")
.Range("AW51:AW53").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW51:AW53")
.Range("AR55:AR58").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR55:AR58")
.Range("AV55:AV58").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV55:AV58")
.Range("AW55:AW58").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW55:AW58")
.Range("AR60:AR68").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR60:AR68")
.Range("AV60:AV68").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV60:AV68")
.Range("AW60:AW68").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW60:AW68")
.Range("AN67").Copy Destination:=wbNeu.Worksheets(.Name).Range("AN67")
.Range("AR70:AR93").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR70:AR93")
.Range("AV70:AV93").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV70:AV93")
.Range("AW70:W93").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW70:AW93")
.Range("AR96:AR97").Copy Destination:=wbNeu.Worksheets(.Name).Range("AR96:AR97")
.Range("AV96:AV97").Copy Destination:=wbNeu.Worksheets(.Name).Range("AV96:AV97")
.Range("AW96:AW97").Copy Destination:=wbNeu.Worksheets(.Name).Range("AW96:AW97")
End With
'Tabellenblatt Waschen neu
With wbAlt.Worksheets("Waschen")
.Range("D9:D10").Copy Destination:=wbNeu.Worksheets(.Name).Range("D9:D10") 'Nutzen
.Range("F9:F10").Copy Destination:=wbNeu.Worksheets(.Name).Range("F9:F10") 'Nutzen Hinweis
End With
'Dampfphase Lötseite
With wbAlt.Worksheets("SMD-Dampfphase_L")
.Range("F10:F13").Copy Destination:=wbNeu.Worksheets(.Name).Range("F10:F13")
.Range("H10:H22").Copy Destination:=wbNeu.Worksheets(.Name).Range("H10:H22")
.Range("F16").Copy Destination:=wbNeu.Worksheets(.Name).Range("F16")
.Range("F18").Copy Destination:=wbNeu.Worksheets(.Name).Range("F18")
.Range("E20").Copy Destination:=wbNeu.Worksheets(.Name).Range("E20")
.Range("G11").Copy Destination:=wbNeu.Worksheets(.Name).Range("G11")
.Range("F22").Copy Destination:=wbNeu.Worksheets(.Name).Range("F22")
.Range("R22").Copy Destination:=wbNeu.Worksheets(.Name).Range("R22")
.Range("J7").Copy Destination:=wbNeu.Worksheets(.Name).Range("J7")
End With
'Dampfphase Bauteilseite
With wbAlt.Worksheets("SMD-Dampfphase_B")
.Range("F10:F13").Copy Destination:=wbNeu.Worksheets(.Name).Range("F10:F13")
.Range("H10:H22").Copy Destination:=wbNeu.Worksheets(.Name).Range("H10:H22")
.Range("F16").Copy Destination:=wbNeu.Worksheets(.Name).Range("F16")
.Range("F18").Copy Destination:=wbNeu.Worksheets(.Name).Range("F18")
.Range("E20").Copy Destination:=wbNeu.Worksheets(.Name).Range("E20")
.Range("G11").Copy Destination:=wbNeu.Worksheets(.Name).Range("G11")
.Range("F22").Copy Destination:=wbNeu.Worksheets(.Name).Range("F22")
.Range("R22").Copy Destination:=wbNeu.Worksheets(.Name).Range("R22")
.Range("J7").Copy Destination:=wbNeu.Worksheets(.Name).Range("J7")
End With
End If
End With
End Sub






Sub Version270(wbAlt, wbNeu)
'Aenderungen zur Version 2.7.0 ***** Transportmittel zusammenstecken neu hinzugefügt ******
With wbAlt.Worksheets("Grunddaten")
If .Range("J1").Value >= 270 Then
With wbAlt.Worksheets("THT_Baut. vorb")
.Range("A48").Copy Destination:=wbNeu.Worksheets(.Name).Range("A48")
.Range("B50").Copy Destination:=wbNeu.Worksheets(.Name).Range("B50")
.Range("K48:K50").Copy Destination:=wbNeu.Worksheets(.Name).Range("K48:K50")
End With
With wbAlt.Worksheets("THT_Leit. vorm")
.Range("B118").Copy Destination:=wbNeu.Worksheets(.Name).Range("B118")
.Range("C120").Copy Destination:=wbNeu.Worksheets(.Name).Range("C120")
.Range("L118:L120").Copy Destination:=wbNeu.Worksheets(.Name).Range("L118:L120")
End With
With wbAlt.Worksheets("THT-Handbest.")
.Range("B34").Copy Destination:=wbNeu.Worksheets(.Name).Range("B34")
.Range("C36").Copy Destination:=wbNeu.Worksheets(.Name).Range("C36")
.Range("J34:K36").Copy Destination:=wbNeu.Worksheets(.Name).Range("J34:K36")
End With
With wbAlt.Worksheets("Selektivloeten")
.Range("M107").Copy Destination:=wbNeu.Worksheets(.Name).Range("M107")
.Range("N109").Copy Destination:=wbNeu.Worksheets(.Name).Range("N109")
End With
With wbAlt.Worksheets("Selektivloeten_2")
.Range("M107").Copy Destination:=wbNeu.Worksheets(.Name).Range("M107")
.Range("N109").Copy Destination:=wbNeu.Worksheets(.Name).Range("N109")
End With
With wbAlt.Worksheets("THT_Einpresst.")
.Range("B35").Copy Destination:=wbNeu.Worksheets(.Name).Range("B35")
.Range("C37").Copy Destination:=wbNeu.Worksheets(.Name).Range("C37")
.Range("L35:L37").Copy Destination:=wbNeu.Worksheets(.Name).Range("L35:L37")
End With
With wbAlt.Worksheets("THT_Fert.mont_1")
.Range("B174").Copy Destination:=wbNeu.Worksheets(.Name).Range("B174")
.Range("C176").Copy Destination:=wbNeu.Worksheets(.Name).Range("C176")
.Range("L174:L176").Copy Destination:=wbNeu.Worksheets(.Name).Range("L174:L176")
End With
End If
End With
End Sub
Anzeige
AW: Perfomance VBA Makro
09.07.2021 13:57:28
ChrisL
Hi
Calculation stellst du zwar zu beginn ab, aber an mehreren Stellen wieder ein. Ganz zum Start ausschalten und ganz zum Schluss erst wieder einschalten. Meine Vermutung wäre, dass die Formelberechnung ursächlich ist und dass diese zu früh wieder eingeschaltet wird.
Auch wenn eine Komplettüberarbeitung zu aufwändig ist, würde ich wenigstens den kurzen Abschnitt mit Scroll und Select bereinigen.
cu
Chris
AW: Perfomance VBA Makro
09.07.2021 15:03:45
stef26
Das Problem ist nicht das Makro.
Ich habe mir mal die Zeitstempel in ein Tabellenblatt geschrieben. Man kann erkennen, dass die Performance allgemein langsamer ist, obwohl nichts am Makro verändert wurde.
Es liegt einzig und allein an dem Thema, dass im Namensmanager ein Bild mit indirekt in ein Tabellenbaltt eigefügt wurde.
Man kann das auch so nachvollziehen. Formel aus dem Namensmanager raus Performance wieder gut.
Diese Aktualisierung hat vermutlich nichts mit der Aktualisierung der Formel zu tun, die man mit ..
.EnableEvents = False
StatusCalc = .Application.Calculation
.Calculation = xlCalculationManual
abschalten kann.
Das Bild wird über Namensmanager und dieser Formel geladen.
=INDIREKT("TM!D"&VERGLEICH('THT_Leit. vorm'!$B$118;TM!$A$1:$A$19;0))
Dies zieht mir meine Performance in den Keller...
Gruß
Stefan
Anzeige
AW: Perfomance VBA Makro
09.07.2021 15:26:19
Daniel
Hi
Ob Applications.Calculation ein oder ausgeschaltet ist, spielt hier schon eine Rolle.
Dein Name hat eine volatile Funktion (Indirekt), dh diese Formel und somit alle von ihr abhängigen Formeln werden bei eingeschalteter Neuberechnung bei jeder Änderung in einem Excelblatt neu berechnet.
Wenn dieser Name das ganze verlangsamt, dann probier mal, obs mit dieser Formel schneller geht:
Das sollte das gleiche Ergebnis bringen, ist aber nicht volatil:
=INDEX(TM!$D:$D";VERGLEICH('THT_Leit. vorm'!$B$118;TM!$A$1:$A$19;0))
Gruß Daniel
AW: Perfomance VBA Makro
09.07.2021 16:30:09
stef26
Hallo Daniel,
danke für den Tip. Ich habe die Formeln mal getauscht.
=INDEX(TM!$D:$D;VERGLEICH('THT_Leit. vorm'!$B$118;TM!$A$1:$A$19;0))
Leider auch da braucht das Makro fast 8min.
Wenn ich dann die 6 Bilder die auf den Namen zugreifen lösche, oder auch nur die Verbindung zu der Formel im Bild lösche, dann läuft das Makro in 45 Sekunden.
Irgendwie stoppt mir das Bild die komplette Performance meines Makros.
Ich glaub ich muss das mit den Bildern anders lösen, obwohl das schon sehr nice war mit der Formel und den Verweis des Bildes auf den Namen.
Ich hatte mal ein Problem mit Bildern, dass die sich nicht aktualisiert haben. Da hab ich glaub ich mit refresh oder mit doevents das im Makro mal zum Aktualisieren gebracht. Da bräuchte ich aktuell so das Gegenteil von refresh oder dontdoevents...
Kann man Bilder auch anders in eine Zelle bringen (geschütztes Blatt)
So in der Art, nur das das Bild in einer Zelle in einem anderen Tabellenblatt liegt?
Image1.Picture = LoadPicture("PFAD\ZUM\BILD\bild.jpg")
Gruß
Stefan
Anzeige
AW: Perfomance VBA Makro
09.07.2021 16:42:22
Daniel
wie du das mit den Bilder anders löst, weiß ich nicht.
was passiert denn, wenn der Name auf eine Zelle ohne Bild verweist?
gehts dann schneller?
wenn das der Fall ist, dann schreibe den Namen so um, dass er eben auf eine Leere Zelle verweist, wenn in einer anderen sonst leeren Zelle ein "x" steht.
also in etwa: =Wenn(TM!$E$1="x";TM!$E$2;Indirekt(....))
dann schreibst du zu beginn in die Zelle das "x", die Referenz geht auf eine leere Zelle und hinterher löscht du das "x" wieder.
oder du veränderst die Formel des Namens im Makro selbst.
Gruß Daniel
AW: Perfomance VBA Makro
09.07.2021 17:11:00
stef26
Hi,
wenn der Name auf eine Zelle ohne Bild verweist, gehts leider auch nicht schneller.
Aber du hast mich ggf. auf die Lösung gebracht.
Ich werde keinen Verweis des Bildes auf eine Zelle machen.
Lasse das Makro laufen.
Wenns durch ist mache ich mit VBA den Verweis auf die Zelle.
Das müsste gehen.
:-)
Stefan
Anzeige
AW: Bild zuweisen
09.07.2021 17:21:00
stef26
Hallo nochmal,
da mein VBA nicht das Beste ist, bräuchte ich nochmal kurz Hilfe.
Das hab ich mit dem Recorder aufgenommen:
'Sheets("THT_Baut. vorb").Select
'Selection.Formula = "=TMBildVM"
Will das natürlich ohne select machen.
Ich habs so probiert, da bringt er mir aber eine Fehlermeldung...
Sheets("THT_Baut. vorb").Formula = "=TMBildVM"
Wie würde das richtig aussehen?
Gruß
Stefan
AW: Bild zuweisen
09.07.2021 17:24:10
Daniel
sieht korrekt aus.
das mit dem Select funktioniert?
was sagt den die Fehlermeldung genau aus?
Gruß Daniel
Danke an ALLE
09.07.2021 18:04:41
stef26
muss natürlich so aussehen..
Worksheets("THT_Baut. vorb").Pictures("Bild1").Formula = "=TMBildVM"
:-)
DANKE an alle die unterstützt haben
Stefan
Anzeige
AW: Perfomance VBA Makro
09.07.2021 16:36:24
stef26
Hi danke für die Rückmeldung,
habs nochmal gecheckt. Das Makro wird erst zu einem Zeitpunkt wieder aktualisiert, wo die 8min schon durchgelaufen sind.
Es liegt, und das kann ich auch wunderbar nachvollziehen, an einem Bild, welches sich mit einer Formel aktualisiert, sollte im Pulldown Menü was geändert werden.
Anscheinend versucht Excel hier nach jeder Codezeile zu Prüfen ob das Bild noch passt.
Anders kann ich mir das nicht mehr vorstellen.
D.h. ich komme vermutlich nur auf eine gute Performance wenn ich das checken ob das Bild geändert werden muss abschalten kann, oder die Bilder nicht mehr über diese Formeln anbinden kann. (Kopieren)
Gruß
Stefan
Anzeige
AW: Perfomance VBA Makro
09.07.2021 16:54:17
ChrisL
Hi
habs nochmal gecheckt. Das Makro wird erst zu einem Zeitpunkt wieder aktualisiert, wo die 8min schon durchgelaufen sind.
Wie und was hast du es gecheckt?
https://www.tabellenexperte.de/excel-im-schneckentempo-volatile-funktionen/
Indirekt ist volatil und kann darum den Prozess verlangsamen. Angenommen die Formel Neuberechnung dauert deswegen ein paar Sekunden. Wenn du die Berechnung nicht durchgängig ausschaltest, wird bei jedem einzelnen Copy/Paste kalkuliert, was sich dann zu den 8 Minuten "hoch-kumuliert". 

Private Sub Worksheet_Calculate()
MsgBox "Hallo Welt"
End Sub
Die Nachrichtenbox dürfte nur ein einziges mal im ganzen Prozess erscheinen. Zum Testen musst du .EnableEvents = False temporär auskommentieren/löschen, sonst funktioniert der Test nicht.
cu
Chris
Anzeige

Links zu Excel-Dialogen

Frame

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige