Sub Fahrzeugeintraege_zuordnen()
Dim objWks As Worksheet
Dim nLastRow As Long
Dim strMsg As String
Dim Zellinhalt_Kennzeichen As String
Dim Kennzeichen As String
Dim i As Integer
Dim erstefreieZeile As Long
<strong>
</strong> Set objWks = ActiveWorkbook.Worksheets(1)
With objWks
If Application.WorksheetFunction.CountA(.Cells) > 0 Then
On Error Resume Next
nLastRow = .Cells.Find(What:="*", After:=.Cells(1), _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
nLastRow = nLastRow - 1
If Err.Number = 0 Then
strMsg = "Letzte Zeile mit Daten: " & nLastRow
Else
strMsg = "Laufzeitfehler '" & CStr(Err.Number)
strMsg = strMsg & "':" & vbCr & Err.Description
End If
On Error GoTo 0
Else
strMsg = "Das Tabellenblatt enthält keine Daten!"
End If
End With
strMsg = "Tabellenblatt: " & objWks.Name & vbCr & vbCr & strMsg
<em><strong>
</strong></em>Dim A As Integer
A = 1<strong><em>
</em></strong>
For i = 1 To nLastRow - 13
Sheets("Quelldatei").Activate
With ActiveSheet.ListObjects("Tabelle27")
<em><strong>
</strong></em> .ListRows(i).Range.Select
<em><strong>
</strong></em> Selection.Copy
<em><strong>
</strong></em>
Kennzeichen = .Range(i + 1, 8)
End With
Select Case Kennzeichen
Case "B-KR122"
<em><strong>
</strong></em> Sheets(Kennzeichen).Activate
<em><strong>
</strong></em> With ActiveSheet.ListObjects("TabelleKR122")
.ListRows(A).Range.Select
End With
<em><strong>
</strong></em> ActiveSheet.Paste
<em><strong>
</strong></em> Selection.ListObject.ListRows.Add hier wird dann die entsprechende Auswahl eingefügt
A = A + 1
End Select
Next i
Set objWks = Nothing
End Sub