VBA - Dreifache Schleife
31.03.2014 12:58:22
Markus
ich bin wieder an einem Punkt angekommen, wo man den Baum vor lauter Bäumen nicht mehr sieht, glaube ich zumindest. Vielleicht sieht ja jemand von euch den Baum bzw. das Brett vor meinen Kopf.
Folgende Ausgangslage.
Ich habe eine Tabelle in der immer wieder neue Daten eingetragen werden. Ich möchte nun das diese Daten in eine zweite eingetragen werden, dabei aber gewisse Kriterien berücksichtigt werden.
Es gibt einen Artikel /Eintrag, der mit 4 Kriterien beschrieben wird. Dieser Artikel/Eintrag kann nun x unterschiedliche Merkmale aufweisen, die alle aufgelistet sind.
Ich möchte nun, dass im zweiten Tabelleblatt jedes Kriterium in eine Spalte eingetragen wird. Hierbei soll geprüft werden, ob das Kriterium bereist vorhanden ist, wenn nicht, neu anlegen werden. Jedes Kriterium hat seine eigene Spalte. Hierbei wird die senkrechte Anorndung der Kriterien von Tabelle 1 in eine waagerechte Anordnung in Tabelle 2 überführt. Sind die Kriterien überprüft und ggf. angelegt, soll nun unter jedem Kriteriem der vollständig beschriebene Artikel/ Eintrag abgelegt werden, dabei immer in die nächste freie Teile des Kriteriums.
Anbei eine Datei, die das verdeutlicht. Ich habe es schon hinbekommen, dass wenn das Kriterium nicht vorhanden ist, es angelegt wird, doch leider wird beim Schreiben des nächsten Kriterium in die nächste Spalte, das erste immer wieder überschrieben. Es muss also eine Schleife sein, die in Tabelle2 sowohl spalten technisch läuft, als auch zeilenmäßig in Tabelle 1 die Kriterien abfragt und in Tabelle 2 überträgt.
In meinem Beispiel wird in Tabelle 3 gezeigt, wie das nachher aussehen soll. In Tabelle 2 wird momentan das eingetagen was der Code so schon ausführt.
Vielleicht kann da mal jemand schauen.
https://www.herber.de/bbs/user/89930.xlsm
Sub test()
Produkt = Worksheets("Tabelle1").Cells(8, 3).Value & " " & Worksheets("Tabelle1").Cells(9, 3). _
_
Value & " " & Worksheets("Tabelle1").Cells(10, 3).Value & " " & Worksheets("Tabelle1").Cells(11, _
3).Value
letztespalte = Sheets("Tabelle2").Cells(1, 256).End(xlToLeft).Column ' Ermittelt die letzte _
beschriebene Spalte
'MsgBox letztespalte
X = 1 'Startwert ab welcher der Spalte
Z = 18 ' Startwert ab welcher der Zeile
With Sheets("Tabelle2")
Dim Y As Integer
Dim leer As Integer
Do
If .Cells(1, X) "" Then
leer = False
Else
leer = True
End If
If Worksheets("Tabelle1").Cells(Z, 3).Value = Worksheets("Tabelle2").Cells(1, X).Value Then
LetzteZeile = Worksheets("Tabelle2").Cells(Rows.Count, X).End(xlUp).Row + 1
Worksheets("Tabelle2").Cells(LetzteZeile, X).Value = Produkt
Exit Sub
Else
Worksheets("Tabelle2").Cells(1, X).Value = Worksheets("Tabelle1").Cells(Z, 3).Value
LetzteZeile = Worksheets("Tabelle1").Cells(Rows.Count, X).End(xlUp).Row + 1
Worksheets("Tabelle2").Cells(LetzteZeile, X).Value = Produkt
End If
X = X + 1
Loop Until leer = True
End With
End Sub
Gruß Markus