AW: Super, aber bitte kleine Abänderung
19.07.2006 14:48:35
fcs
Hallo Nicole,
mit ein paar weiteren Anpassungen geht auch dies. Insbesondere muss dann die letzte mit Daten ausgefüllte Zeile anders ermittelt werden.
mfg
Franz
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