Kopieren ohne Shapes, Links, Formeln...
13.06.2019 09:33:03
Al
ich möchte mit dem folgenden Makro alle beschriebenen Zeilen des aktuellen Tabellenblattes "ONSHORE" ab der Zeile A2 übertragen in ein anderes Excelblatt "LIEFERVERZEICHNIS_test - Kopie.xlsm", dass im Verzeichnis "z:\test\allg\99_ABGABE\" liegt.
Das Kopieren funktionert schon, nur dass leider auch die Formatierungen, Shapes, Links, Formeln etc. übertragen werden. Dies soll aber nicht sein. Es soll lediglich der Textinhalt übertragen werden.
Ferner soll vor jeder eingefügten Zeile mit Textinhalten in der dazugehörigen Spalte A das Datum in Form "JJJJ-MM-TT" eingetragen werden.
Das Makro lautet wi folgt:
Sub Kopieren()
On Error GoTo Dateioffen 'Bei Fehlermeldung wird der Code bis zur entsprechenden _
Sprungmarke übersprungen
Application.ScreenUpdating = False 'Aktualisierungen ausschalten (Flackern beim Ausführen _
des Makros. einfach mal "auskommentieren" und testen wie es ohne ist Smile)
Dim leereZeile, wb As Workbook, ws As Worksheet, sh As Shape 'Variable definieren
' 'Kopieren der beschriebenen Zeilen ab A2 bis letzte
With Sheets("ONSHORE")
.Range("A2:Z" & .Cells(.Rows.Count, 2).End(xlUp).Row + 1).Copy
End With
'Datei öffnen
Workbooks.Open "z:\test\allg\99_ABGABE\LIEFERVERZEICHNIS_test - Kopie.xlsx"
'Aktiviert Tabellenblatt
Workbooks("LIEFERVERZEICHNIS_test - Kopie.xlsx").Sheets("Lieferdaten").Activate
'Erste leere Zeile in der Datei finden
leereZeile = Workbooks("LIEFERVERZEICHNIS_test - Kopie.xlsx").Sheets("Lieferdaten").Cells( _
Rows.Count, 1).End(xlUp).Row + 1
'Kopierte Daten in erste freie Zeile ab Spalte B einfügen
Workbooks("LIEFERVERZEICHNIS_test - Kopie.xlsx").Sheets("Lieferdaten").Range("B" & _
leereZeile & ":AB" & leereZeile).Select
'einfügen ohne Shapes, Links, Formeln - also nur Textinhalte
ActiveSheet.Paste
'vor allen eingefügten Zeilen das Datum eintragen JJJJ-MM-TT
'Datei speichern und dann schließen
With Workbooks("LIEFERVERZEICHNIS_test - Kopie.xlsx")
.Save
.Close
End With
Application.CutCopyMode = True 'Kopierspeicher leeren
Application.ScreenUpdating = True 'Aktualisierungen einschalten
MsgBox ("Daten sind erfolgreich übertragen worden") 'Nachricht dass alles ok ist
GoTo Überspringen
Dateioffen: 'Sprungmarke bei Fehlermeldung
MsgBox ("Kopiervorgang fehlgeschlagen! Zieldatei wird von einem anderem User bearbeitet." & _
Chr(10) & Chr(10) & "Bitte später erneut versuchen.")
' Das Chr(10) bewirkt das der Text dahinter in einer 2ten zeile angezeigt wird
Überspringen:
End Sub
Grüße
Al