Sub DatenAusfuellen()
Dim wsQuelle As Worksheet
Dim wsZiel As Worksheet
Dim letzteZeileQuelle As Long
Dim letzteZeileZiel As Long
Dim i As Long
' Tabellenblätter definieren (Namen ggf. anpassen)
Set wsQuelle = ThisWorkbook.Sheets("Tabelle1")
Set wsZiel = ThisWorkbook.Sheets("Tabelle2")
' Letzte belegte Zeile in der Quelle ermitteln (Spalte A)
letzteZeileQuelle = wsQuelle.Cells(wsQuelle.Rows.Count, "A").End(xlUp).Row
' Schleife, die jede Zeile von Zeile 2 bis zum Ende durchläuft
For i = 2 To letzteZeileQuelle
' Bedingung: Wenn Spalte A nicht leer ist, dann...
If wsQuelle.Cells(i, 1).Value <> "" Then
' Nächste freie Zeile im Ziel-Tabellenblatt ermitteln
letzteZeileZiel = wsZiel.Cells(wsZiel.Rows.Count, "A").End(xlUp).Row + 1
' Daten aus der Quelle in das Ziel übertragen
' Spalte A (Quelle) -> Spalte A (Ziel)
wsZiel.Cells(letzteZeileZiel, 1).Value = wsQuelle.Cells(i, 1).Value
' Spalte B (Quelle) -> Spalte B (Ziel)
wsZiel.Cells(letzteZeileZiel, 2).Value = wsQuelle.Cells(i, 2).Value
End If
Next i
MsgBox "Übertragung abgeschlossen!", vbInformation
End Sub
Option Explicit
Const StartQuelle As Long = 2
Const iZeilen As Long = 35
Sub UebertragenAlleSpalten()
Dim i&, j&, k&, lz&, arrZ(), arrQ: arrQ = Tabelle1.Cells(1, 1).CurrentRegion.Offset(1)
ReDim arrZ(1 To 35, 1 To Tabelle1.Cells(StartQuelle - 1, Columns.Count).End(xlToLeft).Column)
For i = LBound(arrQ) To UBound(arrQ) - 1
For j = 1 To Tabelle1.Cells(StartQuelle - 1, Columns.Count).End(xlToLeft).Column
For k = 1 To iZeilen
arrZ(k, j) = arrQ(i, j)
Next k
Next j
With Tabelle2
lz = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(lz, 1).Resize(iZeilen, UBound(arrZ, 2)) = arrZ
End With
Next i
End Sub
Sub UebertragenNurA()
Dim i&, j&, lz&, arrZ(), arrQ: arrQ = Tabelle1.Range("A" & StartQuelle & ":A" & Tabelle1.Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim arrZ(1 To 35, 1 To 1)
For i = LBound(arrQ) To UBound(arrQ)
For j = 1 To iZeilen
arrZ(j, 1) = arrQ(i, 1)
Next j
With Tabelle2
lz = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(lz, 1).Resize(iZeilen, 1) = arrZ
End With
Next i
End Sub
Option Explicit
Const StartQuelle As Long = 2
Const iZeilen As Long = 35
Sub UebertragenAlleSpalten()
Dim i&, j&, k&, lz&, arrZ(), arrSP(), arrTmp(), arrQ: arrQ = Tabelle1.Cells(1, 1).CurrentRegion.Offset(1)
ReDim arrZ(1 To 35, 1 To Tabelle1.Cells(StartQuelle - 1, Columns.Count).End(xlToLeft).Column)
For i = LBound(arrQ) To UBound(arrQ) - 1
arrTmp = Tabelle1.Range("M" & StartQuelle & ":AU" & StartQuelle).Value
For j = 1 To Tabelle1.Cells(StartQuelle - 1, Columns.Count).End(xlToLeft).Column
For k = 1 To iZeilen
If j < 5 Then
arrZ(k, j) = arrQ(i, j)
ElseIf j = 5 Then
arrZ(k, j) = Tabelle3.Cells(k, 1)
Else
If j < 41 Then arrZ(k, j) = arrTmp(1, j - 5) 'Abfrage da Spalten aus Quelle übersprungen werden.
End If
Next k
Next j
With Tabelle2
lz = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(lz, 1).Resize(iZeilen, UBound(arrZ, 2)) = arrZ
End With
Next i
End Sub
Option Explicit
Const StartQuelle As Long = 2
Const iZeilen As Long = 35
Sub UebertragenAlleSpalten()
Dim i&, j&, k&, lz&, arrZ(), arrSP(), arrTmp(), arrQ: arrQ = Tabelle1.Cells(1, 1).CurrentRegion.Offset(1)
ReDim arrZ(1 To 35, 1 To Tabelle1.Cells(StartQuelle - 1, Columns.Count).End(xlToLeft).Column)
For i = LBound(arrQ) To UBound(arrQ) - 1
arrTmp = Tabelle1.Range("M" & i + StartQuelle - 1 & ":AU" & i + StartQuelle - 1).Value
For j = 1 To Tabelle1.Cells(StartQuelle - 1, Columns.Count).End(xlToLeft).Column
For k = 1 To iZeilen
If j < 5 Then
arrZ(k, j) = arrQ(i, j)
ElseIf j = 5 Then
arrZ(k, j) = Tabelle3.Cells(k, 1)
Else
If j < 41 Then arrZ(k, j) = arrTmp(1, j - 5) 'Abfrage da Spalten aus Quelle übersprungen werden.
End If
Next k
Next j
With Tabelle2
lz = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(lz, 1).Resize(iZeilen, UBound(arrZ, 2)) = arrZ
End With
Next i
End Sub
Option Explicit
Const StartQuelle As Long = 2
Const iZeilen As Long = 35
Const iSpalten As Long = 6
Sub UebertragenAlleSpalten()
Dim i&, j&, k&, lz&, arrZ(), arrSP(), arrTmp(), arrQ: arrQ = Tabelle1.Cells(1, 1).CurrentRegion.Offset(1)
ReDim arrZ(1 To 35, 1 To iSpalten)
For i = LBound(arrQ) To UBound(arrQ) - 1
arrTmp = Tabelle1.Range("M" & i + StartQuelle - 1 & ":AU" & i + StartQuelle - 1).Value
For j = 1 To 6
For k = 1 To iZeilen
If j < 5 Then
arrZ(k, j) = arrQ(i, j)
ElseIf j = 5 Then
arrZ(k, j) = Tabelle3.Cells(k, 1)
Else
arrZ(k, j) = arrTmp(1, k) 'Abfrage da Spalten aus Quelle übersprungen werden.
End If
Next k
Next j
With Tabelle2
lz = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(lz, 1).Resize(iZeilen, UBound(arrZ, 2)) = arrZ
End With
Next i
End Sub