Script für Einfügen in andere Datei anpassen

Sub inTabelleeinfuegenCurrent() Dim shTarget As Worksheet Dim intRow As Integer, i As Integer Set shTarget = Worksheets("Rechnung") intRow = shTarget.Range("A1").CurrentRegion.Rows.Count Rows(ActiveCell.Row).Copy shTarget.Rows(intRow + 1) Application.CutCopyMode = False 'Cancel = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public wbRechnung As Workbook Sub RechnungsDatei_Oeffen() ' selektiert die geöffnetete Arbeitsmappe für Makro "inTabelleeinfuegenCurrent" If Application.Dialogs(xlDialogOpen).Show = False Then Exit Sub Set wbRechnung = ActiveWorkbook End Sub 'oder Sub RechnungsDatei_Setzen() ' selektiert aktive Arbeitsmappe für Makro "inTabelleeinfuegenCurrent" Set wbRechnung = ActiveWorkbook End Sub Sub inTabelleeinfuegenCurrent() If wbRechnung Is Nothing Then MsgBox "Es wurde noch keine Rechnungsdatei per Makro gewählt!" Exit Sub End If Dim shTarget As Worksheet Dim intRow As Integer, i As Integer Set shTarget = wbRechnung.Worksheets("Rechnung") intRow = shTarget.Range("A1").CurrentRegion.Rows.Count Rows(ActiveCell.Row).Copy shTarget.Rows(intRow + 1) Application.CutCopyMode = False 'Cancel = True End Sub

Hallo Nicole,
ich habe mal zwei Varianten gebastelt.
Die erste kopiert Formate und Werte aller Zellen
Die zweite kopiert die Formate und überträgt Werte aus Zellen ohne Formel
Gruß
Franz


'Kopiert Formate und Werte der aktiven Zeile ins andere Blatt
Sub inTabelleeinfuegenCurrent()
If wbRechnung Is Nothing Then
MsgBox "Es wurde noch keine Rechnungsdatei per Makro gewählt!"
Exit Sub
End If
Dim shTarget As Worksheet
Dim intRow As Integer, i As Integer
Set shTarget = wbRechnung.Worksheets("Rechnung")
intRow = shTarget.Range("A1").CurrentRegion.Rows.Count
Rows(ActiveCell.Row).Copy
shTarget.Rows(intRow + 1).PasteSpecial Paste:=xlFormats
shTarget.Rows(intRow + 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
'Cancel = True
End Sub
'Kopiert Formate der aktiven Zeile und Werte aus Zellen ohne Formel ins andere Blatt
Sub inTabelleeinfuegenCurrentNeu()
If wbRechnung Is Nothing Then
MsgBox "Es wurde noch keine Rechnungsdatei per Makro gewählt!"
Exit Sub
End If
Dim shTarget As Worksheet, rngZeile As Range, Zelle As Range
Dim intRow As Integer, i As Integer
Set shTarget = wbRechnung.Worksheets("Rechnung")
intRow = shTarget.Range("A1").CurrentRegion.Rows.Count
Set rngZeile = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1))
rngZeile.Copy
shTarget.Rows(intRow + 1).PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
'Werte aus Zellen ohne Formel übertragen
For Each Zelle In rngZeile
If Zelle.HasFormula = False Then
shTarget.Cells(intRow + 1, Zelle.Column) = Zelle.Value
End If
If Zelle.Column > (shTarget.UsedRange.Column + shTarget.UsedRange.Columns.Count) Then Exit For
Next
'Cancel = True
End Sub

Sub inTabelleeinfuegenCurrent() If wbRechnung Is Nothing Then MsgBox "Es wurde noch keine Rechnungsdatei per Makro gewählt!" Exit Sub End If Dim shTarget As Worksheet, rngZellen As Range Dim intRow As Integer, i As Integer Set shTarget = wbRechnung.Worksheets("Rechnung") intRow = shTarget.Range("A1").CurrentRegion.Rows.Count Application.ScreenUpdating = False 'Aktuelle Zeile, Spalten A(1) bis E (5) kopieren Set rngZellen = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 5)) rngZellen.Copy shTarget.Cells(intRow + 1, 1).PasteSpecial Paste:=xlFormats shTarget.Range(shTarget.Cells(intRow + 1, 1), shTarget.Cells(intRow + 1, 5)).Value = rngZellen.Value 'Aktuelle Zeile, Spalten J(10) bis K (11) kopieren nach Spalten F(6) und G(7) Set rngZellen = Range(Cells(ActiveCell.Row, 10), Cells(ActiveCell.Row, 11)) rngZellen.Copy shTarget.Cells(intRow + 1, 6).PasteSpecial Paste:=xlFormats shTarget.Range(shTarget.Cells(intRow + 1, 6), shTarget.Cells(intRow + 1, 7)).Value = rngZellen.Value Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Sub inTabelleeinfuegenCurrent() If wbRechnung Is Nothing Then MsgBox "Es wurde noch keine Rechnungsdatei per Makro gewählt!" Exit Sub End If Dim shTarget As Worksheet, rngZellen As Range Dim intRow As Integer, i As Integer, intLZ As Integer Set shTarget = wbRechnung.Worksheets("Rechnung") intLZ = 4 'Anzahl Leerzeilen zwischen den kopierten Einträgen 'Letzte ausgefüllte Zeile in Spalten A bis G ermitteln For i = 1 To 7 intRow = Application.WorksheetFunction.Max(intRow, shTarget.Cells(shTarget.Rows.Count, i).End(xlUp).Row) Next Application.ScreenUpdating = False 'Aktuelle Zeile, Spalten A(1) bis E (5) kopieren Set rngZellen = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 5)) rngZellen.Copy shTarget.Cells(intRow + intLZ + 1, 1).PasteSpecial Paste:=xlFormats shTarget.Range(shTarget.Cells(intRow + intLZ + 1, 1), shTarget.Cells(intRow + intLZ + 1, 5)).Value = rngZellen.Value 'Aktuelle Zeile, Spalten J(10) bis K (11) kopieren nach Spalten F(6) und G(7) Set rngZellen = Range(Cells(ActiveCell.Row, 10), Cells(ActiveCell.Row, 11)) rngZellen.Copy shTarget.Cells(intRow + intLZ + 1, 6).PasteSpecial Paste:=xlFormats shTarget.Range(shTarget.Cells(intRow + intLZ + 1, 6), shTarget.Cells(intRow + intLZ + 1, 7)).Value = rngZellen.Value Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Alternative zur Ermittlung der letzten Zeile mit Daten/formatierten Zellen: intRow = shTarget.UsedRange.Row + shTarget.UsedRange.Rows.Count - 1

Beliebteste Forumthreads (12 Monate)

Script für Einfügen in andere Datei anpassen

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Script für Einfügen in andere Datei anpassen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread