Makro braucht zu lang
17.04.2020 11:20:48
Flibustier
ich probiere mich aktuell an VBA um einige Dinge für die Arbeit zu vereinfachen. Nur braucht mein Code ca. 2 1/2 Minuten, was mir zu viel ist. Mir ist bewusst, dass die Funktionen relativ aufwändig sind und dadurch länger brauchen, auch dass mein Code sicherlich noch schlanker gemacht werden kann. Aber ein paar Sekündchen schneller wären toll.
Ich versuche mal den Code zusammen zu fassen:
Es geht darum bestimmte Kreise und Städte aus Deutschland aus anderen Tabellen aufzurufen - also die Daten, die dort gespeichert sind.
Es wird im Hintergrund mindestens eine weitere Excel-Datei geöffnet und aus der sollen bestimmte Zellen und Spalten kopiert und in die aktuelle Datei eingefügt werden. Dabei sollen die Tabellenblätter immer den Namen des jeweiligen zu kopierenden neuen Tabellenblattes bekommen.
Da die zu kopierenden Daten aus formatierten und unformatierten Tabellen stammen, musste ich das Kopieren mit einer Suchfunktion koppeln.
Die externen Tabellen sind nach Bundesländern sortiert und es gibt Ausnahmen, dass manche Kreise in mehreren Dateien enthalten sind oder, dass diese eine andere Struktur zum kopieren aufweisen. Dies habe ich durch eine Errorbehandlung und IF-Anweisungen aufgefangen.
Dies sind die wichtigsten Funktionen. Ich glaube vom Aufbau ist es nicht so kompliziert aber wahrscheinlich sehr redundant.
Hier der Code:
Beste Grüße und Danke :)
Sub Sprechblaseoval2_Klicken()
Dim region_anzahl As Integer
Dim Mails_Anzahl As Integer
Dim i As Integer
Dim ext_wb As Workbook
Dim ext_wb2 As Workbook
Dim int_wb As Workbook
Dim SZelle_Ext As Range
Dim SZelle_Int As Range
Dim Pfad_Verteiler As String
Dim Pfad_Verteiler2 As String
Dim DatAnfang As Date
On Error GoTo FehlerBehandlung
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
DatAnfang = Now
Pfad_Verteiler = Cells(13, 2)
Pfad_Verteiler2 = Cells(14, 2)
region_anzahl = Application.WorksheetFunction.CountIf(Worksheets("Zuordnung Regionen (2)"). _
Range("B133:CS133"), "?*")
Set ext_wb = Workbooks.Open(Pfad_Verteiler, UpdateLinks:=0)
Set int_wb = Workbooks.Open("C:\Users\Philipp Neher\Desktop\Projekt Performance\MasterVersand. _
xlsm")
If Not Worksheets("Versandmaske").Cells(14, 2) = "" Then
Set ext_wb2 = Workbooks.Open(Pfad_Verteiler2, UpdateLinks:=0)
End If
For i = 1 To region_anzahl
If int_wb.Sheets("Zuordnung Regionen (2)").Cells(133, i + 1) = "Kreis Soest" Or int_wb.Sheets(" _
Zuordnung Regionen (2)").Cells(133, i + 1) = "Ennepe-Ruhr-Kreis" Or int_wb.Sheets("Zuordnung Regionen (2)").Cells(133, i + 1) = "Kreis Unna" Or int_wb.Sheets("Zuordnung Regionen (2)").Cells(133, i + 1) = "Kreis Warendorf" Then
ThisWorkbook.Sheets(10 + i).name = int_wb.Sheets("Zuordnung Regionen (2)").Cells(133, i + 1)
Set SZelle_Ext = ext_wb.Sheets(ThisWorkbook.Sheets(10 + i).name).Range("A:D").Find("NGG _
Zitatgeber")
Set SZelle_Int = int_wb.Sheets(ThisWorkbook.Sheets(10 + i).name).Range("A:D").Find("NGG _
Zitatgeber")
int_wb.Sheets(ThisWorkbook.Sheets(10 + i).name).Range("B2:" & "M" & SZelle_Int.Row - 2). _
ClearContents
ext_wb.Sheets(ThisWorkbook.Sheets(10 + i).name).Range("B2:" & "M" & SZelle_Ext.Row - 2).Copy
int_wb.Sheets(ThisWorkbook.Sheets(10 + i).name).Cells(2, 2).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ext_wb.Sheets(ThisWorkbook.Sheets(10 + i).name).Range("B" & SZelle_Ext.Row & ":M300").Copy
int_wb.Sheets(ThisWorkbook.Sheets(10 + i).name).Cells(SZelle_Int.Row, 2).PasteSpecial Paste:= _
xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
ThisWorkbook.Sheets(i).name = int_wb.Sheets("Zuordnung Regionen (2)").Cells(133, i + 1)
Set SZelle_Ext = ext_wb.Sheets(ThisWorkbook.Sheets(i).name).Range("A:D").Find("NGG Zitatgeber")
Set SZelle_Int = int_wb.Sheets(ThisWorkbook.Sheets(i).name).Range("A:D").Find("NGG Zitatgeber")
int_wb.Sheets(ThisWorkbook.Sheets(i).name).Range("B2:" & "K" & SZelle_Int.Row - 2). _
ClearContents
ext_wb.Sheets(ThisWorkbook.Sheets(i).name).Range("B2:" & "K" & SZelle_Ext.Row - 2).Copy
int_wb.Sheets(ThisWorkbook.Sheets(i).name).Cells(2, 2).PasteSpecial Paste:=xlValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ext_wb.Sheets(ThisWorkbook.Sheets(i).name).Range("B" & SZelle_Ext.Row & ":K300").Copy
int_wb.Sheets(ThisWorkbook.Sheets(i).name).Cells(SZelle_Int.Row, 2).PasteSpecial Paste:= _
xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
sprung:
End If
Next i
FehlerBehandlung:
Select Case Err.Number
Case 9
Set SZelle_Ext = ext_wb2.Sheets(ThisWorkbook.Sheets(i).name).Range("A:D").Find("NGG _
Zitatgeber")
Set SZelle_Int = int_wb.Sheets(ThisWorkbook.Sheets(i).name).Range("A:D").Find("NGG _
Zitatgeber")
int_wb.Sheets(ThisWorkbook.Sheets(i).name).Range("B2:" & "K" & SZelle_Int.Row - 2). _
ClearContents
ext_wb2.Sheets(ThisWorkbook.Sheets(i).name).Range("B2:" & "K" & SZelle_Ext.Row - 2). _
Copy
int_wb.Sheets(ThisWorkbook.Sheets(i).name).Cells(2, 2).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ext_wb2.Sheets(ThisWorkbook.Sheets(i).name).Range("B" & SZelle_Ext.Row & ":K300").Copy
int_wb.Sheets(ThisWorkbook.Sheets(i).name).Cells(SZelle_Int.Row, 2).PasteSpecial Paste:= _
xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Resume sprung
Case Else
If Format(Now - DatAnfang, "hh:mm:ss") > "00:05:00" Then
MsgBox "Zeit überschritten - Abbruch der Endlosschleife"
Exit Sub
End If
Resume sprung2
End Select
sprung2:
ext_wb.Sheets("Aussortierung Mails").Range("A2:D3000").Copy
int_wb.Sheets("Aussortierung Mails").Cells(2, 1).PasteSpecial Paste:=xlValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
If Not int_wb.Sheets("Versandmaske").Cells(14, 2) = "" Then
Mails_Anzahl = Application.WorksheetFunction.Match("", int_wb.Sheets("Aussortierung Mails"). _
Range("A:A"), -1)
ext_wb2.Sheets("Aussortierung Mails").Range("A2:D3000").Copy
int_wb.Sheets("Aussortierung Mails").Cells(Mails_Anzahl, 1).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ext_wb2.Save
ext_wb2.Close
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
ext_wb.Save
ext_wb.Close
MsgBox "Datentransfer abgeschlossen. Ich habe " & Format(Now - DatAnfang, "hh:mm:ss") & " _
Sekunden benötigt."
End Sub