VBA: Frage zum Code

[HAMRacer44]

Hallo liebes Forum,

hätte nochmal eine Frage... diesmal bzgl. eines Code-Schnipsels

Aufgabe des Codes:
Habe ein Userform, in welches ich Lieferanten und deren Produkte eintrage bzw. per OptionButtons auswählen kann. Je nach dem ob ein Lieferant bereits vorhanden ist, soll das neu hinzuzufügende Produkt unterhalb des letzten Produkts in Tabelle5 geschrieben werden. Wenn der Lieferant nicht vorhanden ist, soll die Liste in Tabelle5 um eine Spalte erweitert werden, der Name des Lieferanten in Zeile 1 und darunterliegend die Produkte eingetragen werden.

Soweit klappt das aber nicht ganz zufriedenstellend.

Nun zum Problem:
Wenn ich Lieferant 1 eingebe mitsamt Produkt, trägt der Code den Lieferant und sein Produkt korrekt ein (in die nächste freie Spalte, Zeile 1 den Namen und in Zeile 2 das Produkt). Wenn ich einen weiteren Lieferanten eintrage, geht das auch so weiter (funktioniert).
Wenn ich aber Lieferant 1 um ein Produkt erweitern will, überschreibt er mir das vorher eingetragene Produkt in Zeile 2 (zwar in der richtigen Spalte), obwohl das zweite Produkt in Zeile 3 geschrieben werden sollte usw...
Das Problem besteht mit jedem Mal, in dem ich einen bestehenden Lieferanten um ein Produkt erweitern will. Habe (s. auch im Code) eine Sortierung eingefügt - liegt hier der Hund begraben?

Hoffe habe mich klar ausgedrückt - Beispiel-Code siehe unten; Beispiel-Datei (mir rudimentärem Problem) ist ebenfalls dabei

Code:

'Definiert die Spalten und Zeilen in Tabelle5
Dim lastSpalteProduktpalette As Integer
Dim lastZeileProduktpalette As Integer
Dim opt As Object

'Sucht jeweils die nächste freie Zeile und freie Spalte
lastSpalteProduktpalette = Tabelle5.Cells(1, Columns.Count).End(xlToLeft).Column + 1 'Sucht nächst-freie Spalte ausgehend Zeile 1 (Tabelle2)
lastZeileProduktpalette = Tabelle5.Cells(Rows.Count, 1).End(xlUp).Row + 1 'Sucht nächst-freie Zeile für Produktpalette


If Tabelle5.Range("A1:ZZ1").Find(frmLieferwerkHinzufügen.txtNameNeuesLieferwerk.Value, , xlValues, xlWhole, xlByColumns) Is Nothing Then 'Prüft, ob Lieferwerk bzw. deren Produktpalette bereits vorhanden
    Tabelle5.Cells(1, lastSpalteProduktpalette) = frmLieferwerkHinzufügen.txtNameNeuesLieferwerk.Value  'Falls Lieferwerk nicht vorhanden, wird es eingetragen
        For Each opt In frmLieferwerkHinzufügen.Controls
        If TypeOf opt Is MSForms.OptionButton Then
          If opt.Value = True Then Tabelle5.Cells(lastZeileProduktpalette, lastSpalteProduktpalette).Value = opt.Caption
          ElseIf txtProduktpaletteAndere.TextLength > 3 Then Tabelle5.Cells(lastZeileProduktpalette, lastSpalteProduktpalette).Value = txtProduktpaletteAndere  'Trägt die Produktart eines neuen Lieferwerks ein
        End If
      Next
ElseIf Not Tabelle5.Range("A1:ZZ1").Find(frmLieferwerkHinzufügen.txtNameNeuesLieferwerk.Value, , xlValues, xlWhole, xlByColumns) Is Nothing Then 'Wenn Lieferwerk vorhanden ist
      For Each opt In frmLieferwerkHinzufügen.Controls
            If TypeOf opt Is MSForms.OptionButton Then
              If opt.Value = True Then Tabelle5.Cells(Tabelle5.Cells(lastZeileProduktpalette, Tabelle5.Range("A1:ZZ1").Find(frmLieferwerkHinzufügen.txtNameNeuesLieferwerk.Value, , xlValues, xlWhole, xlByColumns).Column).End(xlUp).Row + 1, Tabelle5.Range("A1:ZZ1").Find(frmLieferwerkHinzufügen.txtNameNeuesLieferwerk.Value, , xlValues, xlWhole, xlByColumns).Column).Value = opt.Caption 'Übernimmt Werte der OptionButtons
              ElseIf txtProduktpaletteAndere.TextLength > 3 Then Tabelle5.Cells(lastZeileProduktpalette, Tabelle5.Range("A1:ZZ1").Find(frmLieferwerkHinzufügen.txtNameNeuesLieferwerk.Value, , xlValues, xlWhole, xlByColumns).Column).Value = txtProduktpaletteAndere
            End If
      Next
End If

'Sortiert die Produktpalette nach jedem Eintrag
  For Each rngSpalte In Tabelle5.Cells(1, 1).CurrentRegion.Columns
    rngSpalte.Sort Key1:=rngSpalte.Cells(2), Order1:=xlAscending, Header:=xlYes
  Next rngSpalte

Danke wie immer für eure Vorschläge und danke für eure investierte Zeit!

LG Domi

[snb]

Ein .xlsx Datei beinhaltet keine Code weder ein Userform

[Kuwer]

Hallo Domi,

ungetestet:

Code:

Sub bbb()
'Definiert die Spalten und Zeilen in Tabelle5
Dim lastSpalteProduktpalette As Integer
Dim lastZeileProduktpalette As Integer
Dim opt As Object
Dim rngF As Range

'Sucht jeweils die nächste freie Zeile und freie Spalte
lastSpalteProduktpalette = Tabelle5.Cells(1, Columns.Count).End(xlToLeft).Column + 1 'Sucht nächst-freie Spalte ausgehend Zeile 1 (Tabelle2)
lastZeileProduktpalette = Tabelle5.Cells(Rows.Count, 1).End(xlUp).Row + 1 'Sucht nächst-freie Zeile für Produktpalette

Set rngF = Tabelle5.Range("A1:ZZ1").Find(frmLieferwerkHinzufügen.txtNameNeuesLieferwerk.Value, , xlValues, xlWhole, xlByColumns)
If rngF Is Nothing Then 'Prüft, ob Lieferwerk bzw. deren Produktpalette bereits vorhanden
    Tabelle5.Cells(1, lastSpalteProduktpalette) = frmLieferwerkHinzufügen.txtNameNeuesLieferwerk.Value  'Falls Lieferwerk nicht vorhanden, wird es eingetragen
    For Each opt In frmLieferwerkHinzufügen.Controls
      If TypeOf opt Is MSForms.OptionButton Then
        If opt.Value = True Then Tabelle5.Cells(lastZeileProduktpalette, lastSpalteProduktpalette).Value = opt.Caption
        ElseIf txtProduktpaletteAndere.TextLength > 3 Then Tabelle5.Cells(lastZeileProduktpalette, lastSpalteProduktpalette).Value = txtProduktpaletteAndere  'Trägt die Produktart eines neuen Lieferwerks ein
      End If
    Next
Else 'Wenn Lieferwerk vorhanden ist
    Set rngF = rngF.EntireColumn.Cells(Rows.Count, 1).End(xlUp).Offset(1)
    For Each opt In frmLieferwerkHinzufügen.Controls
          If TypeOf opt Is MSForms.OptionButton Then
            If opt.Value = True Then
              rngF.Value = opt.Caption 'Übernimmt Werte der OptionButtons
            Else
              If txtProduktpaletteAndere.TextLength > 3 Then
                rngF.Value = txtProduktpaletteAndere
              End If
            End If
          End If
    Next opt
End If

'Sortiert die Produktpalette nach jedem Eintrag
  For Each rngSpalte In Tabelle5.Cells(1, 1).CurrentRegion.Columns
    rngSpalte.Sort Key1:=rngSpalte.Cells(2), Order1:=xlAscending, Header:=xlYes
  Next rngSpalte
End Sub

Gruß Uwe

[HAMRacer44]

Hallo Uwe,

danke für deine Lösung.

Habe sie gerade (ungetestet) eingebaut - jetzt ist sie getestet funktionsfähig ;)

Danke dir

Gruß Domi