Varianten erstellen

[Inspektor]

Hallo Zusammen

Ich sehe wohl den Wald voller Bäume nicht mehr :)
Und zwar habe ich in der beiliegenden Excel File eine Art Varianten Generator.

Wenn man die Prozedur ausführt  generiert er aufgrund meiner Daten in Tabelle 1 alle Varianten in Tabelle 2.
Nun habe ich jedoch das Problem, dass es nur zehn Zeilen A8-A17 generiert obwohl  ich das gerne bis zur letzte Zelle mit Inhalt wünsche (indem Fall bis A100)

Was mache ich falsch? :)

Code:

Option Explicit

Sub varianten()
 Dim varColor As Variant, varVariante As Variant, varSizes As Variant, varOutput() As Variant
 Dim lngC As Long, lngV As Long, lngI As Long, lngS As Long, lngN As Long

 With Sheets("Sheet1")
   varColor = .Range("_color")
   varVariante = .Range("_var")
   varSizes = .Range("_size")
   lngC = Application.Sum(.Range("_var")) * Application.CountA(.Range("_size"))
   If UBound(varColor, 1) <> UBound(varVariante, 1) Then Exit Sub
   ReDim varOutput(1 To lngC, 1 To 3)
 
   lngI = 1
 
   For lngV = 1 To UBound(varVariante, 1)
     varOutput(lngI, 1) = varColor(lngV, 1)
     varOutput(lngI, 2) = varVariante(lngV, 1)
     For lngS = 1 To UBound(varSizes, 1)
       For lngN = 1 To varVariante(lngV, 1)
         varOutput(lngI, 3) = varSizes(lngS, 1)
         lngI = lngI + 1
       Next
     Next
   Next
 
   Worksheets("Sheet2").Range("A2").CurrentRegion = ""
   Worksheets("Sheet2").Range("A2").Resize(UBound(varOutput, 1), 3) = varOutput
 End With
 
End Sub

Tausend Dank für die Hilfe im voraus
Inspektor

[schauan]

Hallöchen,

Deine benannten Bereiche gehen nur bis Zeile 17 !?

[Inspektor]

Hi Schauam

Genau, nur bis Zeile 17, wie kann ich das ändern das es bis zur letzten Zeile geht oder zumindest bis zum Beispiel Zeile 1000 ?

Danke und Gruss

Inspi

[Gast 123]

Hallo

eine Lösung auf die schnelle, die aber ausreichen könnte, ist den Code wie unten mit Resize zu erweitern.
Ob hier auch mit Resize gearbeitet werden muss bitte selbst testen:    Application.Sum(.Range("_var").Resize(lzA, 1))

ich hoffe diese kleine Erweiterung wird helfen die Aufgabe zu lösen

mfg  Gast 123

Code:

  With Sheets("Sheet1")
   'LastZell in Spalte A nach unten suchen
   lzA = .Range("A8").End(xlDown).Row
   varColor = .Range("_color").Resize(lzA, 1)
   varVariante = .Range("_var").Resize(lzA, 1)
   varSizes = .Range("_size").Address
   lngC = Application.Sum(.Range("_var")) * Application.CountA(.Range("_size"))

[Inspektor]

Hi Gast123

Ich erhalte ständig einen Unverträglichkeitsfehler in der Zeile

Code:

For lngS = 1 To UBound(varSizes, 1)

hmm, alles korrekt deklariert aber da macht mir der VBA Teufel ein Strich durch die Rechnung :)

Woran könnte das liegen??

Gruss

[Gast 123]

Hallo

ich habe mir mal eine Referenzliste der Workbook Namen erstellt und dabei was interessantes festestellt.

Diese Namen beinhalten nicht nur den bereich sondern auch "Index" und "CountA" für diesen Bereich!  Dann dürfte mein Vorschlag zur Erweiterung nicht klappen.  Wir sind aber nicht dumm, Bereiche lassen sich per Vba umschreiben!!  Der Bereich wurde von mir mit mindestens 17 und max. 1000 Zeilen begrenzt  Ggf. bitte selbst aendern.  Bitte mal testen ob es damit klappt.  

Ganz unten ist ein Makro mit den Originalwerten, damit man jederzeit den Urzustand wiederherstellen knn.  
Würde mich freuen wenn es so klappt.

mfg  Gast 123

Code:

Option Explicit

Sub varianten()
 Dim varColor As Variant, varVariante As Variant, varSizes As Variant, varOutput() As Variant
 Dim lngC As Long, lngV As Long, lngI As Long, lngS As Long, lngN As Long, lzA As Long

 With Sheets("Sheet1")
   'LastZell in Spalte A nach unten suchen
   lzA = .Range("A8").End(xlDown).Row
   İf lzA < 17 Then lzA = 17       'Mindestens 17 Zeilen
   If lzA > 1000 then lzA = 1000   'auf Max. 1000 begrenzen
   
  'Zeile 17 in Namen Bereich durch lzA auswechseln
  ThisWorkbook.Names("_color").RefersTo = "=Sheet1!$A$8:INDEX(Sheet1!$A$8:$A$" & lzA & ",COUNTA(Sheet1!$A$8:$A$" & lzA & "))"
  ThisWorkbook.Names("_size").RefersTo = "=Sheet1!$I$8:INDEX(Sheet1!$I$8:$I$" & lzA & ",COUNTA(Sheet1!$I$8:$I$" & lzA & "))"
  ThisWorkbook.Names("_var").RefersTo = "=Sheet1!$B$8:INDEX(Sheet1!$B$8:$B$" & lzA & ",COUNTA(Sheet1!$B$8:$B$" & lzA & "))"
   
   varColor = .Range("_color")
   varVariante = .Range("_var")
   varSizes = .Range("_size")
   lngC = Application.Sum(.Range("_var")) * Application.CountA(.Range("_size"))
   
   If UBound(varColor, 1) <> UBound(varVariante, 1) Then Exit Sub
   ReDim varOutput(1 To lngC, 1 To 3)
 
   lngI = 1

   For lngV = 1 To UBound(varVariante, 1)
     varOutput(lngI, 1) = varColor(lngV, 1)
     varOutput(lngI, 2) = varVariante(lngV, 1)
     For lngS = 1 To UBound(varSizes, 1)
       For lngN = 1 To varVariante(lngV, 1)
         varOutput(lngI, 3) = varSizes(lngS, 1)
         lngI = lngI + 1
       Next
     Next
   Next
 
   Worksheets("Sheet2").Range("A2").CurrentRegion = ""
   Worksheets("Sheet2").Range("A2").Resize(UBound(varOutput, 1), 3) = varOutput
 End With
 
End Sub


'alten Originalzustand der Workbook Namen wiederherstellen

Sub Originalformel_einsetzen()
ThisWorkbook.Names("_color").RefersTo = "=Sheet1!$A$8:INDEX(Sheet1!$A$8:$A$17,COUNTA(Sheet1!$A$8:$A$17))"
ThisWorkbook.Names("_size").RefersTo = "=Sheet1!$I$8:INDEX(Sheet1!$I$8:$I$17,COUNTA(Sheet1!$I$8:$I$17))"
ThisWorkbook.Names("_var").RefersTo = "=Sheet1!$B$8:INDEX(Sheet1!$B$8:$B$17,COUNTA(Sheet1!$B$8:$B$17))"
End Sub

[Inspektor]

Was soll ich sagen, du bist der KING!!!
Nach einer Woche habe ich endlich exakt das gewünschte Resultat.
Und dann geht's auch noch derart brutal schnell, die Prozedur.

TAUSEND Dank Gast123!!!!!