Worksheet kopieren
15.03.2021 13:47:22
André
Ich bin gerade daran ein Makro einzufügen, welches mehrere Aufgaben erledigen soll.
Die 1. Aufgabe besteht darin von einem Workbook2 Daten ins Workbook1 zu schreiben. Dies funktioniert gut.
In der 2. Aufgabe soll das Makro dann aus einem Workbook3 nicht das Sheet, sondern die Daten daraus kopieren (Range A1:G500) und im Workbook1 ins Sheet2 einfügen.
Leider gibts hier einen Laufzeitfehler, welchen ich nicht finde. Denke aber er besteht in den letzten Zeilen, da in der Zwischenablage die Daten bereits zu finden sind. - Kann mir hier jemand weiterhelfen?
Folgendes Makro ist dabei entstanden:
Private Sub CommandButton1_Click()
Dim WbDatei1 As String
Dim WbDatei2 As String
Dim strFilter As String
Dim strFileName As Variant
Dim varDatei1 As Variant
Dim varDatei2 As Variant
Dim Pfad As String
Dim strFile As String
Dim Wert1 As Variant
Dim Wert2 As Variant
Dim Wert3 As Variant
Dim Wert4 As Variant
Dim Wert5 As Variant
Dim Wert6 As Variant
Dim Wert7 As Variant
Dim Wert8 As Variant
Dim Wert9 As Variant
Dim i As Integer
'** Alle alten Daten in "Stammdaten" und "enacto-Report löschen
With ThisWorkbook.Worksheets("Stammdaten")
For i = 1 To .Columns.Count
If Cells(1, i) = "Standort" Then
Range(Cells(2, i), Cells(1000, i)).ClearContents
End If
If Cells(1, i) = "Verrechnungspunkt" Then
Range(Cells(2, i), Cells(1000, i)).ClearContents
End If
If Cells(1, i) = "ID VP 2017" Then
Range(Cells(2, i), Cells(1000, i)).ClearContents
End If
If Cells(1, i) = "Konto" Then
Range(Cells(2, i), Cells(1000, i)).ClearContents
End If
If Cells(1, i) = "KST/PC" Then
Range(Cells(2, i), Cells(1000, i)).ClearContents
End If
If Cells(1, i) = "WE" Then
Range(Cells(2, i), Cells(1000, i)).ClearContents
End If
If Cells(1, i) = "NKSL" Then
Range(Cells(2, i), Cells(1000, i)).ClearContents
End If
If Cells(1, i) = "AE" Then
Range(Cells(2, i), Cells(1000, i)).ClearContents
End If
If Cells(1, i) = "Zuordnung" Then
Range(Cells(2, i), Cells(1000, i)).ClearContents
End If
Next i
End With
WbDatei1 = ActiveWorkbook.Name
'** Laufwerk und Pfad definieren, welcher geöffnet werden soll
ChDir "I:\D5\Engineering & Services\Engineering\20 Energie\03 Einkauf und Verrechnung\01 _
Elektrizität\B Stromverrechnung\Einheitstarif\Konzept\Aufbau und Pflege Masterliste all VP\"
'** Dateifilter definieren
varDatei1 = Application.GetOpenFilename("Excel-Arbeitsmappen, *.xlsm," & _
"Alle Excel-Dateien, *.xlsm*", 2, "Bitte wählen Sie die aktuelle Masterliste aus!")
If varDatei1 = False Then
Exit Sub
Else
'** Gewählte Datei öffnen
Dim wb As Workbook
Dim ws As Worksheet
Set ws = Workbooks.Open(varDatei1).Sheets("KST")
ws.Activate
With ws
For i = 1 To .Columns.Count
If .Cells(1, i).Value = "Standort" Then
Wert1 = .Range(.Cells(2, i), .Cells(1000, i))
End If
If .Cells(1, i).Value = "Verrechnungspunkt" Then
Wert2 = .Range(.Cells(2, i), .Cells(1000, i))
End If
If .Cells(1, i).Value = "ID VP 2017" Then
Wert3 = .Range(.Cells(2, i), .Cells(1000, i))
End If
If .Cells(1, i).Value = "Konto" Then
Wert4 = .Range(.Cells(2, i), .Cells(1000, i))
End If
If .Cells(1, i).Value = "KST/PC" Then
Wert5 = .Range(.Cells(2, i), .Cells(1000, i))
End If
If .Cells(1, i).Value = "WE" Then
Wert6 = .Range(.Cells(2, i), .Cells(1000, i))
End If
If .Cells(1, i).Value = "NKSL" Then
Wert7 = .Range(.Cells(2, i), .Cells(1000, i))
End If
If .Cells(1, i).Value = "AE" Then
Wert8 = .Range(.Cells(2, i), .Cells(1000, i))
End If
If .Cells(1, i).Value = "Zuordnung" Then
Wert9 = .Range(.Cells(2, i), .Cells(1000, i))
End If
Next i
End With
'** schliesst File ohne zu speichern
ActiveWorkbook.Close SaveChanges:=False
Workbooks(WbDatei1).Activate
With Worksheets("Stammdaten")
For i = 1 To .Columns.Count
If .Cells(1, i) = "Standort" Then
.Range(.Cells(2, i), .Cells(1000, i)) = Wert1
End If
If .Cells(1, i) = "Verrechnungspunkt" Then
.Range(.Cells(2, i), .Cells(1000, i)) = Wert2
End If
If .Cells(1, i) = "ID VP 2017" Then
.Range(.Cells(2, i), .Cells(1000, i)) = Wert3
End If
If .Cells(1, i) = "Konto" Then
.Range(.Cells(2, i), .Cells(1000, i)) = Wert4
End If
If .Cells(1, i) = "KST/PC" Then
.Range(.Cells(2, i), .Cells(1000, i)) = Wert5
End If
If .Cells(1, i) = "WE" Then
.Range(.Cells(2, i), .Cells(1000, i)) = Wert6
End If
If .Cells(1, i) = "NKSL" Then
.Range(.Cells(2, i), .Cells(1000, i)) = Wert7
End If
If .Cells(1, i) = "AE" Then
.Range(.Cells(2, i), .Cells(1000, i)) = Wert8
End If
If .Cells(1, i) = "Zuordnung" Then
.Range(.Cells(2, i), .Cells(1000, i)) = Wert9
End If
Next i
End With
Application.DisplayAlerts = True
End If
'** aktueller enacto-Report einfügen
'** Laufwerk und Pfad definieren, welcher geöffnet werden soll
ChDir "I:\D5\Engineering & Services\Engineering\20 Energie\03 Einkauf und Verrechnung\01 _
Elektrizität\B Stromverrechnung\Einheitstarif\Produktiv\"
'** Dateifilter definieren
varDatei2 = Application.GetOpenFilename("Excel-Arbeitsmappen, *.xls," & _
"Alle Excel-Dateien, *.xls*", 2, "Bitte wählen Sie das aktuelle GMZ Verrechnungsdoc aus!")
If varDatei2 = False Then
Exit Sub
Else
'** Gewählte Datei öffnen
Dim wb2 As Workbook
Dim ws2 As Worksheet
Set ws2 = Workbooks.Open(varDatei2).Sheets("Verrechnungsdoc GMZ V1.0")
ws2.Activate
Sheets("Verrechnungsdoc GMZ V1.0").Range("A1:G500").Copy
Workbooks(WbDatei1).Activate
Worksheets("enacto-Report").Activate
Range("A1:G500").Paste
Workbooks(varDatei2).Activate
'** schliesst File ohne zu speichern
ActiveWorkbook.Close SaveChanges:=False
Workbooks(WbDatei1).Activate
Application.DisplayAlerts = True
End If
End Sub