AW: Daten kopieren - aber nur ausgewählte
10.11.2008 13:01:00
Chris
Servus,
probiers mal so:
Sub t()
Dim lngLetzte As Long, LetzteSpalteQuelle As Long, LetzteSpalteZiel As Long
Dim wkBQuelle As Workbook, wkBZiel As Workbook, wks As Worksheet, wks1 As Worksheet
Dim DatenArray() As Variant, SpaltenArray() As Long, ZeilenArray() As Long
Dim rSuche As Range, rFinde As Range, rngCopy As Range, k As Long, i As Long, x As Long
'Workbooks.Open ThisWorkbook.Path & "\Mappe1.xls"
Set wkBQuelle = ThisWorkbook
Set wkBZiel = Workbooks("Mappe1.xls") ' Mappe1.xls durch Dateiname von BB ersetzten
Set wks = wkBQuelle.Worksheets("Tabelle1")
Set wks1 = wkBZiel.Worksheets("Tabelle1")
With wks
LetzteSpalteQuelle = .Cells(1, Columns.Count).End(xlToLeft).Column
End With
With wks1
LetzteSpalteZiel = .Cells(1, Columns.Count).End(xlToLeft).Column
End With
ReDim DatenArray(1 To LetzteSpalteZiel)
ReDim SpaltenArray(1 To LetzteSpalteZiel, 1 To 2)
For i = LBound(DatenArray()) To UBound(DatenArray())
DatenArray(i) = wks1.Cells(1, i)
Next i
Set rFinde = wks.Range(wks.Cells(1, 1), wks.Cells(1, LetzteSpalteQuelle))
For i = LBound(DatenArray()) To UBound(DatenArray())
Set rSuche = rFinde.Find(what:=DatenArray(i), lookAt:=xlWhole, LookIn:=xlValues)
If Not rSuche Is Nothing Then
SpaltenArray(i, 1) = rSuche.Column
SpaltenArray(i, 2) = i
End If
Next i
lngLetzte = wks.Cells(Rows.Count, 6).End(xlUp).Row
For i = 2 To lngLetzte
If Year(wks.Cells(i, 6)) = Year(Date) Then
ReDim Preserve ZeilenArray(x)
ZeilenArray(x) = i
x = x + 1
End If
Next i
For i = LBound(SpaltenArray(), 1) To UBound(SpaltenArray(), 1)
For k = LBound(ZeilenArray()) To UBound(ZeilenArray())
If SpaltenArray(i, 1) = 0 Then Exit For
wks.Cells(ZeilenArray(k), SpaltenArray(i, 1)).Copy
wks1.Cells(Rows.Count, SpaltenArray(i, 2)).End(xlUp).Offset(1, 0).PasteSpecial Paste:= _
xlPasteValues
Next k
Next i
wkBZiel.Close
End Sub
Das Makro kommt entweder in ein allgemeines Modul oder in das Tabellenmodul "Tabelle1" in der Datei AA (Quelldatei). Das Mappe1.xls muss durch den Dateinamen von BB ersetzt werden. Datei BB muss geöffnet sein.
Gruß
Chris