VBA Kopieren einfügen überschreiben
01.03.2022 09:15:06
Andreas
hab einen Code, der Werte aus einer Datei, nenne die mal "Planung" kopiert und diese in eine zweite Datei überträgt "Übersicht".
In Übersichts-Datei, werden die Werte dann immer in die nächste freie Zeile kopiert.
Hier der Schnipsel, der das machen soll:
ThisWorkbook.Worksheets("Planung").Range("FL2:KT2").Copy
Workbooks("Übersicht.xlsm").Worksheets("Übersicht").Range("A99999").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Danke vorab und Gruß Andreas
Da ich mich mit VBA leider sehr wenig auskenne, hier zur Sicherheit mal der Vollständige Code:
'unter Anbindung von Bibliothek "Microsoft Scripting Runtime":
'Extras, Verweise..., Hacken bei "Microsoft Scripting Runtime"
Dim FSO As New FileSystemObject
Dim DateiPfad As String
Const sPfadErledigt As String = "X:\Andreas\"
Const DateinamenMuster = " K xxx.xlsm"
Private Sub CommandButton1_Click()
Dim Datei As File
'1. Prüfen, dass der Pfad gültig ist
'2. Prüfen, ob Dateinumemr gültig ist
'3. Prüfen ob Datei bereit existiert
'4. Daten übertragen
'5. Datein Speichern
'1.
If Pfad_prüfen(sPfadErledigt) Is Nothing Then
MsgBox "Verzeichnis """ & sPfadErledigt & """ nichtvorhadne oder nicht gefunden.", vbExclamation
Exit Sub
End If
'2.
If Worksheets("Ausgang").Range("AK1").Value = "" Or Not IsNumeric(Worksheets("Planung").Range("AK1").Value) Then
MsgBox "Nummer """ & Worksheets("Planung").Range("AK1").Value & """ ist für diese Datei nicht gültig.", vbExclamation
Exit Sub
End If
'3
DateiPfad = sPfadErledigt & Replace(DateinamenMuster, "xxx", Worksheets("Planung").Range("AK1").Value)
Set Datei = Datei_prüfen(sPfadErledigt & Replace(DateinamenMuster, "xxx", Worksheets("Planung").Range("AK1").Value))
If Not Datei Is Nothing Then
If MsgBox("Datei """ & Datei.ShortPath & """ existiert bereits. " & vbCr & vbCr & "Überschreiben?", vbYesNo + vbQuestion) vbYes Then
Exit Sub
End If
End If
'4.
ThisWorkbook.Worksheets("Planung").Range("FL2:KT2").Copy
Workbooks("Übersicht.xlsm").Worksheets("Übersicht").Range("A99999").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'5.
ThisWorkbook.SaveAs DateiPfad, xlOpenXMLWorkbookMacroEnabled
' ThisWorkbook.Close
End Sub
Function Pfad_prüfen(Pfad As String) As Folder
'gibt einen Folder-Objekt zurück, wenn Pfad vorhanden, sonst Nothing
On Error Resume Next
Set Pfad_prüfen = FSO.GetFolder(Pfad)
End Function
Function Datei_prüfen(Pfad As String) As File
'gibt einen File-Objekt zurück, wenn Pfad vorhanden, sonst Nothing
On Error Resume Next
Set Datei_prüfen = FSO.GetFile(Pfad)
End Function