Clever-Excel-Forum

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,

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

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

LindaB

Fennek

1Matthias