optimieren
René
ich hab da mal zwei Fragen:
Kann man meine Versuche vielleicht schlanker machen und optimieren dass das ganze schneller läuft?
Das speichern der Daten funktioniert irgendwie nicht. Dieser Befehl wird ganz einfach übergangen. Was mache ich da falsch?
Besten Dank schon mal zum voraus für Eure Hilfe.
Freundliche Grüsse
René
Sub daten_uebernahme()
Dim wborig As Workbook, wbziel1 As Workbook, wbziel2 As Workbook
Dim wksorig As Worksheet, wksziel1 As Worksheet, wksziel2 As Worksheet, wksziel3 As Worksheet, zusatz1 As Worksheet, zusatz2 As Worksheet, zusatz3 As Worksheet
Set wborig = Workbooks.Open("d:\vbs\berechnung\Ber_Stat_RT_V3_Grunddaten.xlsm", ReadOnly:=True)
Set wksorig = wborig.Worksheets(1)
Set wbziel1 = Workbooks.Open("D:\VBS\Berechnung\Ber_Stat_RT_V3_Ber1.xlsx", ReadOnly:=False)
Set wksziel1 = wbziel1.Worksheets(1)
Set wksziel2 = wbziel1.Worksheets(2)
Set wksziel3 = wbziel1.Worksheets(3)
Set wbziel2 = Workbooks.Open("d:\vbs\berechnung\Ber_Stat_RT_V3_Zusatz.xlsx", ReadOnly:=False)
Set zusatz1 = wbziel2.Worksheets(1)
Set zusatz2 = wbziel2.Worksheets(2)
Set zusatz3 = wbziel2.Worksheets(3)
'alte daten löschen
'With wbziel
wksziel1.Activate
Rows("2:40000").Select
Selection.Delete shift:=xlUp
Range("A2").Select
wksziel2.Activate
Rows("2:40000").Select
Selection.Delete shift:=xlUp
Range("a2").Select
wksziel3.Activate
Rows("3:40000").Select
Selection.Delete shift:=xlUp
Range("a2").Select
'End With
'daten übertragen
wksorig.Activate
Range("A2:P40000").Select
Selection.Copy
wksziel1.Activate
Range("a2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("A2").Select
'zeichen zoll entfernen
Cells.Replace what:=".1""", replacement:=".1 ", lookat:=xlPart, Searchorder:=xlByRows
Cells.Replace what:=".4""", replacement:=".4 ", lookat:=xlPart, Searchorder:=xlByRows
Cells.Replace what:=".1 ", replacement:=".1 ", lookat:=xlPart, Searchorder:=xlByRows
Cells.Replace what:=".4 ", replacement:=".4 ", lookat:=xlPart, Searchorder:=xlByRows
wksorig.Activate
Application.CutCopyMode = False
Range("a2").Select
'daten für typenkürzung übertragen
wksziel1.Activate
Range("l2:l40000").Select
Selection.Copy
wksziel3.Activate
Range("a2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
wksziel1.Activate
Application.CutCopyMode = False
Range("a2").Select
wksziel3.Activate
'auto ausfüllen typenkürzung
Range("b2:f2").Select
Selection.AutoFill Destination:=Range("b2:f40000"), Type:=xlFillDefault
'gekürzte typen übertragen
Range("f2:f40000").Select
Selection.Copy
wksziel1.Activate
Range("q2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("a2").Select
wksziel3.Activate
Application.CutCopyMode = False
Range("a2").Select
wksziel1.Activate
Range("a2:q40000").Select
Selection.Copy
wksziel2.Activate
Range("a2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("a2").Select
wksziel1.Activate
Application.CutCopyMode = False
Range("a2").Select
'duplikate entfernen
wksziel2.Activate
ActiveSheet.Range("$A$1:$P$40000").RemoveDuplicates Columns:=3, Header:= _
xlYes
Range("a2").Select
zusatz1.Activate
Rows("2:40000").Select
Selection.Delete shift:=xlUp
Range("A2").Select
zusatz2.Activate
Rows("2:40000").Select
Selection.Delete shift:=xlUp
Range("A2").Select
zusatz3.Activate
Rows("2:40000").Select
Selection.Delete shift:=xlUp
Range("A2").Select
wksziel1.Activate
Range("a2:b40000 f2:f40000 h2:h40000 m2:o40000 q2:q40000").Select
Selection.Copy
zusatz1.Activate
Range("a2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("a2").Select
wksziel1.Activate
Range("f2:f40000").Select
Selection.Copy
zusatz1.Activate
Range("c2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("a2").Select
wksziel1.Activate
Range("h2:h40000").Select
Selection.Copy
zusatz1.Activate
Range("d2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("a2").Select
wksziel1.Activate
Range("m2:o40000").Select
Selection.Copy
zusatz1.Activate
Range("e2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("a2").Select
wksziel1.Activate
Application.CutCopyMode = False
Range("a2").Select
wbziel1.Save SaveChanges = True
wbziel1.Close
wbziel2.Save SaveChanges = True
wbziel2.Close
wborig.Close
'ActiveWorkbook.Saved = True diese befehle funtkionieren nicht warum wissen die götter
'ActiveWorkbook.Close
'ActiveWorkbook.Saved = True
'ActiveWorkbook.Close
'ActiveWorkbook.Close