Hilfestellung For To Zeilenreferenzen
26.03.2021 19:19:04
Richi
Ich hoffe auf eure Hilfe.
Ich krieg den Dreh nicht raus mit meinen Zeielreferenzen die Zellen richtig zu befüllen.
Ausgangslage:
Tabelle "Quelle" zeigt in den Spalten W01-W12 Werte auf in Spalte B die Revision und Spalte F das Dokument mit welchem eine Reparatur ausgeführt wurde.
Ziel:
In jeder Zelle W01-W12 in welcher ein Wert hinterlegt ist, soll in Tabelle "Ziel" das entsprechende Dokument aus Spalte F eingesetzt werden.
Final sollen diese pro Revision unter der jeweiligen W01-W12 untereinander aufgelistet werden ohne dazwischenliegende Leerzellen.
Mit meinem Code krieg ich dies Teilweise hin, jedoch überschreibt es mir einige Zellen und ich finde nicht raus warum das so ist.
PS: In Tabelle "So sollte es sein" hab ich die Finale richtige Auslistung hinterlegt
Hier der Link zum File: https://www.herber.de/bbs/user/145148.xlsm
Musste dieses Abspecken Originalfile enthält über 3000 Zeilen
Freue mich auf eure Hilfestellung.
Liebe Gruess
Richi
Option Explicit
<pre>Sub Tasks_pro_Revision_Woche()
Dim wb As Workbook
Dim wsQ As Worksheet
Dim wsZ As Worksheet
Dim sheetnew As Worksheet
Dim Sheet As Worksheet
Dim lZQ, lZZ, lSQ, lSZ As Long 'Letzte Zeilen, Spalten aus Quelle und Ziel
Dim StartSQ As Long 'Start Spalte Quelle
Dim StartZQ As Long 'Start Zeile Quelle
Dim StartSZ As Long 'Start Spalte Ziel
Dim StartZZ As Long 'Start Zeile Ziel
Dim Endespalte As Long ' Ende derjenigen Spalten die zu Zählen sind
Dim EZGrp As Long 'Zähler Ende einer Gruppe Ziel
Dim ZZZ As Long 'Zeilenzähler Ziel
Dim ZNGrp 'Zeilenreferenz neue Gruppe
Dim i As Integer
Dim j As Integer
Set wb = ThisWorkbook
Set wsQ = wb.Worksheets("Quelle")
Set wsZ = wb.Worksheets("Ziel")
'-----------Referenz Startpunkte für Spalten Zeilen in Quelle und Ziel---------------
StartSQ = 13
StartZQ = 2
StartSZ = 3
StartZZ = 2
Endespalte = 18 'Letzt zu Zählende Spalte bezüglich Zelleninhalte
lZQ = wsQ.Cells(wsQ.Rows.Count, 1).End(xlUp).Row
lZZ = wsZ.Cells(wsZ.Rows.Count, 1).End(xlUp).Row
lSQ = wsQ.Cells(1, wsQ.Columns.Count).End(xlToLeft).Column
lSZ = wsZ.Cells(1, wsZ.Columns.Count).End(xlToLeft).Column
'-----------Daten löschen---------------
wsZ.Select
wsZ.Range("A2:DD15000").Select
Selection.ClearContents
wsZ.Range("A2").Select
For i = StartZQ To lZQ
EZGrp = wsZ.UsedRange.Rows.Count 'Letzte beschriebene Zeile des Ranges in Ziel
If wsQ.Cells(i, 2).Value = wsZ.Cells(wsZ.Rows.Count, 2).End(xlUp).Value Then 'Vergleich Zeile Quelle mit letzter Zeile Ziel Reg gleich
If wsQ.Application.WorksheetFunction.CountA(Range(wsQ.Cells(i, StartSQ), wsQ.Cells(i, Endespalte))) > 0 Then 'Prüfen ob Quellen Zeile einen Eintrag hat
For j = StartSQ To Endespalte 'Alle Spalten einer Zeile durchlaufen und Daten eintragen
If wsQ.Cells(i, j) <> "" Then 'Wenn in neuer Gruppe eine Zelle in erster Zeile leer ist
wsZ.Cells(wsZ.Cells(wsZ.Rows.Count, j - (StartSQ - StartSZ)).End(xlUp).Row + 1, 1).Value = wsQ.Cells(i, 1) 'In erste freie Zeile der Spalte schreiben
wsZ.Cells(wsZ.Cells(wsZ.Rows.Count, j - (StartSQ - StartSZ)).End(xlUp).Row + 1, 2).Value = wsQ.Cells(i, 2)
wsZ.Cells(wsZ.Cells(wsZ.Rows.Count, j - (StartSQ - StartSZ)).End(xlUp).Row + 1, j - (StartSQ - StartSZ)).Value = wsQ.Cells(i, 2) & " - " & wsQ.Cells(i, 6) & " - " & wsQ.Cells(i, 7)
End If
Next j
End If
Else
If wsQ.Cells(i, 2).Value <> wsZ.Cells(wsZ.Rows.Count, 2).End(xlUp).Value Then 'Vergleich Zeile Quelle mit letzter Zeile Ziel Reg ungleich
ZNGrp = wsZ.UsedRange.Rows.Count + 1 'Referenzzeile Start Gruppe
If wsQ.Application.WorksheetFunction.CountA(Range(wsQ.Cells(i, StartSQ), wsQ.Cells(i, Endespalte))) > 0 Then 'Prüfen ob Quellen Zeile einen Eintrag hat
For j = StartSQ To Endespalte 'Alle Spalten einer Zeile durchlaufen und Daten eintragen
If wsQ.Cells(i, j) <> "" Then 'Wenn in neuer Gruppe eine Zelle in erster Zeile leer ist
wsZ.Cells(ZNGrp, 1).Value = wsQ.Cells(i, 1)
wsZ.Cells(ZNGrp, 2).Value = wsQ.Cells(i, 2)
If wsZ.Cells(ZNGrp, j - (StartSQ - StartSZ)) = "" Then
wsZ.Cells(ZNGrp, j - (StartSQ - StartSZ)).Value = wsQ.Cells(i, 2) & " - " & wsQ.Cells(i, 6) & " - " & wsQ.Cells(i, 7)
Else
' wsZ.Cells(wsZ.Cells(wsZ.Rows.Count, j - (StartSQ - StartSZ)).End(xlUp).Row + 1, 1).Value = wsQ.Cells(i, 1) 'In erste freie Zeile der Spalte schreiben
' wsZ.Cells(wsZ.Cells(wsZ.Rows.Count, j - (StartSQ - StartSZ)).End(xlUp).Row + 1, 2).Value = wsQ.Cells(i, 2)
wsZ.Cells(wsZ.Cells(wsZ.Rows.Count, j - (StartSQ - StartSZ)).End(xlUp).Row + 1, j - (StartSQ - StartSZ)).Value = wsQ.Cells(i, 2) & " - " & wsQ.Cells(i, 6) & " - " & wsQ.Cells(i, 7)
End If
End If
Next j
End If
End If
End If
Next i
End Sub</pre>