Office: (Office 2019) Positionsnummern Vergabe bei (Verbundene Zellen)

Nabend Allerseits,

Frage:
Anpassung eines bereits Geschrieben Codes, Bsp. Demo-Mappe anbei (Die Nummerierung ist im unterem Bereich den Macro's).

Verwendete Elemente:
Tabelle> "wsLK",
Daten> Spalte A: Überschrift (Pos.), Spalte F: Überschrift (Pos.)
Modul> wsLK

Problem:
Nummerierung der Positions-Spalte "A" u. "F"., in Kombination Verbundener Zellen.
Leider Funktioniert es bei mir nicht.


Ziel:
Ich möchte erreichen das ich Positionsnummern Vergebe ab Zeile 2 aber es handelt sich hierbei um Verbundene Zellen zu je 11 Zeilen.
Pos. 1: Spalte "A" "Zeile 2-12" u. Spalte "F" "Zeile 2-12"
Pos. 2: Spalte "A" "Zeile 13-23" u. Spalte "F" "Zeile 13-23"
Diese möchte ich fortlaufend weiter führen bis die Positionnummer 110 mit je 11 Zeilen erreicht ist.

Verwendung:
Macro als Vorlage zum Erstellen einer Tabelle


Grus Leon

 

Hallo Leon,

teste mal:

Code:

Option Explicit

Sub StartTabelleSchreiben() 'hier eventuell Einstellungen ändern
    Dim arrKopf():      arrKopf = Array("Pos", "Ü-Schrift  1", "Ü-Schrift  2", "Ü-Schrift  3", "Ü-Schrift  4", "Pos", "Ü-Schrift  1", "Ü-Schrift  2", "Ü-Schrift  3", "Ü-Schrift  4", "Ü-Schrift  5", "Ü-Schrift  6", "Ü-Schrift  7")
    Dim arrFarben():    arrFarben = Array(RGB(82, 82, 82), RGB(123, 123, 123), RGB(201, 201, 201), RGB(138, 138, 255), RGB(102, 102, 255))
    Dim arrFontFarbe(): arrFontFarbe = Array(RGB(255, 255, 255), RGB(0, 0, 0))
    Dim Blattname$: Blattname = "wsLK"
    Dim wks As Worksheet
    For Each wks In ThisWorkbook.Sheets
        If wks.Name = Blattname Then
            Application.DisplayAlerts = False
            wks.Delete
            Application.DisplayAlerts = True
        End If
    Next
    With ThisWorkbook
        .Sheets.Add After:=Sheets(Sheets.Count)
        .ActiveSheet.Name = Blattname
    End With
    Call TabelleErzeugen(WksName:=Blattname, Kopfzeile:=1, FontFarbe:=arrFontFarbe, Kopfhoehe:=87.75, Spaltenbreite:=10.71, Spaltennamen:=arrKopf, Farben:=arrFarben, AnzahlBloecke:=110)
End Sub

Sub TabelleErzeugen(ByVal WksName As String, ByVal Kopfzeile As Long, ByVal FontFarbe As Variant, ByVal Kopfhoehe As Double, ByVal Spaltenbreite As Double, ByVal Spaltennamen As Variant, ByVal Farben As Variant, ByVal AnzahlBloecke As Long)
    Dim lz&, i&, booFw As Boolean, rng1, rng2
    With Sheets(WksName)
        .Cells(1, 1).RowHeight = Kopfhoehe
        .Cells(1, 1).Resize(1, UBound(Spaltennamen) + 1) = Spaltennamen
        With .Range(.Cells(1, 1), .Cells(1, UBound(Spaltennamen) + 1))
            .ColumnWidth = Spaltenbreite
            .Interior.Color = Farben(4)
            .Font.Color = FontFarbe(0)
            .Orientation = 90
            .VerticalAlignment = xlCenter
        End With
        For i = 1 To AnzahlBloecke * 11 + 1 Step 2
            If Len(rng1) < 180 Then
                rng1 = rng1 & "A" & i & ":M" & i & ","
            Else
                rng1 = rng1 & "A" & i & ":M" & i & ","
                .Range(Left(rng1, Len(rng1) - 1)).Interior.Color = Farben(3)
                rng1 = ""
            End If
            If Len(rng2) < 180 Then
                rng2 = rng2 & "A" & i + 1 & ":M" & i + 1 & ","
            Else
                rng2 = rng2 & "A" & i + 1 & ":M" & i + 1 & ","
                .Range(Left(rng2, Len(rng2) - 1)).Interior.Color = Farben(4)
                rng2 = ""
            End If
        Next i
        If rng1 <> "" Then .Range(Left(rng1, Len(rng1) - 1)).Interior.Color = Farben(3)
        If rng2 <> "" Then .Range(Left(rng2, Len(rng2) - 1)).Interior.Color = Farben(4)
        .Range("rng1").Interior.Color = Farben(3)
        .Cells(1, 1).Interior.Color = Farben(0)
        .Cells(1, 6).Interior.Color = Farben(0)
        lz = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        For i = 1 To AnzahlBloecke
            With .Range("A" & lz & ":A" & lz + 10)
                .Interior.Color = IIf(booFw = True, Farben(1), Farben(2))
                .MergeCells = True
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Value = i
            End With
            With .Range("F" & lz & ":F" & lz + 10)
                .Interior.Color = IIf(booFw = True, Farben(1), Farben(2))
                .MergeCells = True
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Value = i
            End With
            If booFw = False Then
                booFw = True
            Else
                booFw = False
            End If
            lz = lz + 11
        Next i
        .Rows(AnzahlBloecke * 11 + 2).Delete
    End With
End Sub

Gruß Uwe

 

Hallo Leon,

ändere am Ende der Prozedur "TabelleErzeugen" die Zeile:

Code:

.Rows(AnzahlBloecke * 11 + 2).Delete

in:

Code:

If lz <= AnzahlBloecke * 11 + 2 Then .Rows(AnzahlBloecke * 11 + 2).Interior.Color = xlNone

Gruß Uwe

 

Hallo Leon,

es gibt keinen vernünftigen Grund, in einer Liste verbundene Zellen einzubauen. Die machen nur Probleme. Schade finde ich es, dass sich trotzdem immer wieder Leute finden, die solch einen Murks mit Lösungsvorschlägen unterstützen.
Dann noch ein Wort zum "Design" deiner Liste: davon bekommt man Augenkrebs. Wenn du es schon gerne bunt hast, warum nimmst du dann nicht eine formatierte (intelligente) Tabelle? Die braucht man auch nicht über hunderte Zeilen vorab ausfüllen, das geschieht bei jeder neuen Zeile von alleine.

 

Um mal ins gleiche Horn wie Klaus-Dieter zu stoßen:
Mein Excel 365 hat einen sogenannten Barrierefreiheit-Assistenten.
Dieser meldet mir exakt die genannten Mängel:

 

Ja. Die Farben - wem es so gefällt (mir nicht).

Ich würde das eigentlich auf die 2 Graustufen begrenzen oder noch besser ganz ohne Farben und nur eine Trennlinie pro Pos.- Nr. Aber das muss der TO selber mit sich ausmachen. Da halte ich mich raus.

Was die verbundenen Zellen in einer Tabelle anlangt: Ein EDV tauglicher Tabellenaufbau nebst Pos.- Nr. je Datensatz ist definitiv der bessere Weg zur Datenerfassung. Auch wenn 11 Zeilen dieselbe Pos.- Nr. enthalten.

Wenn es dann eine Auswertung braucht was so ein Layout vielleicht erfordert (Chef gerecht) kommt man mit DropDown und paar Formeln problemlos zurecht und bekommt die Ausgabe des per DropDown abgefragten Positionsnummer/Bereich angezeigt.

Aber auch das muss der TO Schluss letztendlich mit sich selbst ausmachen. Ich habe ihm den Kram beim Bierchen gepinselt. Es ist bequem konfigurierbar falls sich was ändert. Was er damit macht ist dann seine Sache.

Gruß Uwe