Markierte Zeile kopieren

Guten Abend zusammen
Ich brauche Hilfe von Profis
Bis jetzt läuft ein Macro mit jeder Menge Select und Copy. in Excel 16 läuft das nicht mehr, d.h. es Zeit die Anwendung zu Überarbeiten. Wenn ich die Code sehe die Ihr schreibt ist mein gefringgel doch noch aus dem letzten Jahrhundert....
Mappe 1, Tabelle A: Die Zeile mit der Aktiven Zelle in Spalte A soll kopiert werden und in Tabelle B Zeile 2 eingefügt werden, d.h. Zeilen sollten nach unten verschoben werden. Weiter soll die selbe Zeile in eine Datei 2, Arbeitsblatt D ebenfalls in Zeile 2 eingefügt werden, wiederum inkl. nach unten verschieben der bestehenden Zellen.
In Mappe 1 soll die Markierte Zelle gelöscht werden und die Datei gespeichert geschlossen werden.
Wenn das ein Fall für Auftragsprogrammierung ist habe ich volles Verständnis
Vielen Dank für eure Hilfe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Guten Abend EtoPHG
Mit rotem Kopf und einem Fragezeichen wie das unter 2010 noch läuft sende ich Dir den Code.
Ab 2013 explodiert vor lauter hin und her der Bildschirm..........
Sub Zusage() 'XLSM ready
PathAFR = GetSetting("W&L", "Optionen", "PathAngeboteFakturaRechnung", "") & "\" (wird nicht mehr gebraucht, nur noch direkter Pfad)
On Error GoTo Fehler
Cells(ActiveCell.Row, 1).Select
Rows(ActiveCell.Row).Select (Markierte Zelle ist Rot, soll aber wieder ohne Farbe sein)
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Application.ScreenUpdating = False
ActiveCell.Range("A1:I1").Select (ganze Zeile kopieren)
Selection.Copy
Sheets("Zusagen").Select
Range("A2").Select
Selection.Insert Shift:=xlDown
Sheets("Offertbearbeitung").Select
Application.CutCopyMode = False
Workbooks.Open Filename:="O:\Test 2020\Archiv\Offerten\" & "Faktura.xlsm"
Windows("ANGEBOTE.xlsm").Activate
Selection.Copy
Windows("Faktura.xlsm").Activate
Range("A2").Select
Selection.Insert Shift:=xlDown
ActiveWorkbook.Save
Windows("ANGEBOTE.xlsm").Activate
ActiveCell.EntireRow.Delete
Range("A1").Select
ActiveWorkbook.Save
ActiveWorkbook.Close SaveChanges:=True
Exit Sub
Fehler:
ErrorAngebote
End Sub

Sub test1() 'Dein Code Cells(ActiveCell.Row, 1).Select Rows(ActiveCell.Row).Select Debug.Print Selection.Address With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With End Sub Sub test2() 'Luschis Code With Cells(ActiveCell.Row, 1).EntireRow Debug.Print .Address With .Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With End With End Sub

Sub test3() 'Luschis Code Dim wb As Workbook, rg As Range Set rg = Cells(ActiveCell.Row, 1).EntireRow With rg Debug.Print .Address With .Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With End With Set rg = Nothing 'wenn nur draus kopoert werden soll, schreibgeschützt öffnen Set wb = Workbooks.Open(Filename:="O:\Test 2020\Archiv\Offerten\" & "Faktura.xlsm", ReadOnly:=True) '... Set wb = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread