|
Hallo Alfons,
so sollte es gehen:
Option Explicit
Option Base 1 'ist notwendig!
Sub Kopieren()
Dim Spalten: Spalten = Array(1, 3, 6, 9, 12) 'Quellspalten
Dim Quellblatt As Object, Zielblatt As Object
Set Quellblatt = ThisWorkbook.Sheets("Tabelle1") 'ggfls. anpassen
Set Zielblatt = ThisWorkbook.Sheets("Tabelle2") 'ggfls. anpassen
Dim ZeileFirst As Long 'erste freie Zeile in Tabelle2
Dim Inhalte() As Variant 'Inhalte einer Quellzeile
Dim CanCopy As Boolean 'es soll kopiert werden, da Inhalte vorhanden
Dim i, j 'Laufvariablen
ReDim Inhalte(UBound(Spalten))
ZeileFirst = WorksheetFunction.Max(2, Zielblatt.Cells(Rows.Count, 1).End(xlUp).Row)
With Quellblatt
For i = 1 To 8
CanCopy = False
For j = 1 To UBound(Spalten) 'Lesen der Inhalte
If .Cells(i, Spalten(j)).Text <> "" Then
CanCopy = True
Inhalte(j) = .Cells(i, Spalten(j)).Value
Else
Inhalte(j) = ""
End If
Next j
If CanCopy Then 'nur übertragen, wenn etwas vorhanden
For j = 1 To UBound(Spalten)
Zielblatt.Cells(ZeileFirst, j) = Inhalte(j)
Next j
ZeileFirst = ZeileFirst + 1
End If
Next i
End With
End Sub
Gruß der AlteDresdner
|