AW: Löschen beibringen
13.11.2008 17:33:36
fcs
Hallo Micha,
ich hab die Zeile und Spalte für das EInfügen in der Zieltabelle noch als Optionale Parameter eingebaut.
Standardmäßig wird ab der 1. Zeile eingefügt.
Gruß
Franz
Sub KopierenSpalten_A_bis_G_ab_Zeile_8()
Call Kopieren_Spalten_abZeile(strZielWorkbook:="SCM Gesamt PortsTEST.xls", _
Spalte1:=1, Spalte2:=7, Startzeile:=8, ZeileZiel:=1)
End Sub
Sub KopierenSpalten_A_bis_H_ab_Zeile_1()
Call Kopieren_Spalten_abZeile(strZielWorkbook:="SCM Gesamt PortsTEST.xls", _
Spalte1:=1, Spalte2:=8, Startzeile:=1, strZielWorksheet:="CSV")
End Sub
Sub Kopieren_Spalten_abZeile(strZielWorkbook As String, Spalte1 As Long, _
Spalte2 As Long, Startzeile As Long, Optional strZielWorksheet As String = "", _
Optional ZeileZiel As Long = 1, Optional SpalteZiel As Long = 1)
'Kopieren von Daten aus dem aktiven Tabellenblatt in das aktive Blatt der Zieldatei
'strZielWorkbook = Name der ZielDatei
'Spalte1 = Nummer der 1. Spalte
'Spalte2 = Nummer der Letzten Spalte
'Startzeile = Nummer der Zeile ab der kopiert werden soll
'strZielWorksheet = Name des Ziel-Tabellenblatts, Wenn ="" dann aktives blatt
'ZeileZiel = Nummer der Zeile ab der eingefügt werden soll, Standard = 1
'SpalteZiel = Nummer der Zeile ab der eingefügt werden soll, Standard = 1
On Error GoTo Fehler
Dim wksQuelle As Worksheet, rngBereich As Range, wb As Workbook, wksZiel As Worksheet
' Prüfen, ob ZielArbeitsmappe geöffnet
For Each wb In Workbooks
If LCase(wb.Name) = LCase(strZielWorkbook) Then
Exit For
End If
Next
If wb Is Nothing Then
MsgBox "Die Zieldatei """ & strZielWorkbook & """ ist nicht geöffnet!"
GoTo Fehler
End If
Set wksQuelle = ActiveSheet
With wksQuelle
'zu kopierenden Bereich ermitteln in Spalten ab StartZeile
Set rngBereich = .Range(.Cells(Startzeile, Spalte1), _
.Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row, Spalte2))
End With
With Workbooks(strZielWorkbook)
.Activate
If strZielWorksheet = "" Then
Set wksZiel = ActiveSheet
Else
Set wksZiel = .Worksheets(strZielWorksheet)
wksZiel.Activate
End If
With wksZiel
'alles löschen in Spalten ab StartZeile
.Range(.Cells(ZeileZiel, SpalteZiel), _
.Cells(.Rows.Count, SpalteZiel + rngBereich.Columns.Count - 1)).Clear
'Daten kopieren und ab StartZeile einfügen
rngBereich.Copy Destination:=.Cells(ZeileZiel, SpalteZiel)
'Spalten formatieren
With .Range(.Columns(SpalteZiel), .Columns(SpalteZiel + rngBereich.Columns.Count - 1))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Columns.AutoFit
End With
Range("A1").Select
End With
End With
Fehler:
If Err.Number 0 Then
MsgBox "Fehler-Nr. " & Err.Number & vbLf & Err.Description
End If
End Sub