VBA-code verkleinern

[LindaB]

Hallo ;)

Mein vba-code ist extrem lang...

was der code soll:
ich habe mehrere Bereiche ("Antipasto1", "Antipasto2"...)
diese Bereiche sollen, wenn sie denn nicht leer sind, in die zelle x zusammengefasst mit Bindestrich geschrieben werden.
wenn leer wird der nächste bereich betrachtet, 
ansonsten (wenn werte Vorhanden) wird 2 Zeilen unter dem ersten x die zusammenfassung von "Antipasto2" geschrieben.

und so weiter...

also es funktioniert, aber ist extrem unübersichtlich =(

Code:

Public Sub Antipasto()

Dim v As Variant, sZK As String, a As Range, x, rngB As Range
Dim gericht
x = Range("A5").Address


Set rngB = Sheets("Eingabe").Range("Antipasto1") 'Bereich anpassen
If WorksheetFunction.CountA(rngB) <> 0 Then
If Not rngB Is Nothing Then
       For Each a In rngB.Areas
           If IsArray(a.Value) Then
               For Each v In a.Value
                   If v <> "" Then sZK = sZK & " - " & v
               Next
           Else
               sZK = " - " & a.Value
           End If
       Next
       gericht = IIf(sZK <> "", Mid$(sZK, 2), Empty)
       gericht = Right(gericht, Len(gericht) - 2)
   End If
Sheets("Layout").Range(x).Value = gericht
x = ActiveSheet.Range(x).Offset(2, 0).Address
Else: x = x
End If

v = ""
sZK = ""
Set rngB = Sheets("Eingabe").Range("Antipasto2") 'Bereich anpassen
If WorksheetFunction.CountA(rngB) <> 0 Then
If Not rngB Is Nothing Then
       For Each a In rngB.Areas
           If IsArray(a.Value) Then
               For Each v In a.Value
                   If v <> "" Then sZK = sZK & " - " & v
               Next
           Else
               sZK = " - " & a.Value
           End If
       Next
       gericht = IIf(sZK <> "", Mid$(sZK, 2), Empty)
       gericht = Right(gericht, Len(gericht) - 2)
   End If
Sheets("Layout").Range(x).Value = gericht
x = ActiveSheet.Range(x).Offset(2, 0).Address

Else: x = x
End If

v = ""
sZK = ""
Set rngB = Sheets("Eingabe").Range("Antipasto3") 'Bereich anpassen
If WorksheetFunction.CountA(rngB) <> 0 Then
If Not rngB Is Nothing Then
       For Each a In rngB.Areas
           If IsArray(a.Value) Then
               For Each v In a.Value
                   If v <> "" Then sZK = sZK & " - " & v
               Next
           Else
               sZK = " - " & a.Value
           End If
       Next
       gericht = IIf(sZK <> "", Mid$(sZK, 2), Empty)
       gericht = Right(gericht, Len(gericht) - 2)
   End If
Sheets("Layout").Range(x).Value = gericht
x = ActiveSheet.Range(x).Offset(2, 0).Address
Else: x = x
End If

v = ""
sZK = ""
Set rngB = Sheets("Eingabe").Range("Antipasto4") 'Bereich anpassen
If WorksheetFunction.CountA(rngB) <> 0 Then
If Not rngB Is Nothing Then
       For Each a In rngB.Areas
           If IsArray(a.Value) Then
               For Each v In a.Value
                   If v <> "" Then sZK = sZK & " - " & v
               Next
           Else
               sZK = " - " & a.Value
           End If
       Next
       gericht = IIf(sZK <> "", Mid$(sZK, 2), Empty)
       gericht = Right(gericht, Len(gericht) - 2)
   End If
Sheets("Layout").Range(x).Value = gericht
x = ActiveSheet.Range(x).Offset(2, 0).Address
Else: x = x
End If

End Sub

Hat jemand eine Idee wie ich das vereinfachen kann?
Wenn ja vielleicht kurz nen Tipp das ich das das nächste mal alleine schaffe =D


liebe Grüße,

[Fennek]

Hallo,

es ist zu mühsam den Code zu entziffern. Einfacher wäre es, wenn du die Daten zeigen würdest.

Als Beispiel (ungetestet)

Code:

Ar = application.transpose(Range("A1:A20"))
msgbox join(Ar, ", ")

Es gibt mehrere Varianten mit vergleichbaren Ergebnissen.

mfg

[1Matthias]

Moin!
Packe deine ganzen Namen in dem Blatt / Datei in ein Array und durchlaufe dann das Array. Der Code ist ja für jeden Namensbereich der selbe. Könnte dann so aussehen (ungetestet). Iim Array einfach die Namen ergänzen. Anstelle vom Namen steht dann in der set Zeile der entsprechende NAme aus dem Array.

Code:

Public Sub Antipasto()

Dim v As Variant, sZK As String, a As Range, x, rngB As Range
Dim myNamen
Dim eintrag As Long
Dim gericht

myNamen = Array("Antipasto1", "Antipasto2", "Antipasto3")

x = Range("A5").Address

For eintrag = 0 To UBound(myNamen)

   Set rngB = Sheets("Eingabe").Range(myNamen(eintrag)) 'Bereich anpassen
   If WorksheetFunction.CountA(rngB) <> 0 Then
   If Not rngB Is Nothing Then
          For Each a In rngB.Areas
              If IsArray(a.Value) Then
                  For Each v In a.Value
                      If v <> "" Then sZK = sZK & " - " & v
                  Next
              Else
                  sZK = " - " & a.Value
              End If
          Next
          gericht = IIf(sZK <> "", Mid$(sZK, 2), Empty)
          gericht = Right(gericht, Len(gericht) - 2)
      End If
   Sheets("Layout").Range(x).Value = gericht
   x = ActiveSheet.Range(x).Offset(2, 0).Address
   Else: x = x
   End If
   
   v = ""
   sZK = ""

Next

End Sub

VG