Zellen bei identischen Werten verbinden

Question

Hallo zusammen

ich [xurl=http://jamaipa.de|Jamaipa - Suche ohne Spam und Shops]suche[/url] eine Möglichkeit identische Zellen automatisch per VBA verbinden zu lassen. Einen funktionierenden Code (siehe unten) habe ich hier bereits im [xurl=http://www.supportnet.de|Supportnet - Computer und Internet Forum]Forum[/url] gefunden.


Für mein Problem passt es aber leider noch nicht ganz. Ich versuche damit auf Basis von einzelnen Tagen eine Jahresübersicht (Anzeige von Jahr, Monat und KW) zu generieren.

Zur Verdeutlichung

in Zeile A steht das Datum (z.B. A1: 01.01.18, A2: 02:01.18, usw.)
in Zeile B steht das zugehörige Jahr (also 365 mal 2018, dann 2019, usw.)
in Zeile C steht der zugehörige Monat (also 31 mal Januar, 30 mal Februar, usw.)
in Zeile D steht die zugehörige KW

Das Start und Zieldatum ändere ich in einem anderen Feld, wodurch sich die Darstellung jederzeit ändern lässt. Über den VBA-Code funktioniert die Zentrierung der identischen Zellen leider nur einmal... denn sobald ich das Start und Enddatum ändere, passt die Verbindung nicht mehr.

Funktioniert das ganze, wenn ich die Zeilen B, C und D so belasse und mir die Felder in 3 zusätzlichen Zeilen verbinden lasse?

Falls ja, wie muss ich den Code bearbeiten, dass er mir die Jahre, Monate und KW in jeweils einer neuen Zeilen (E, F und G) verbindet, sodass ich jederzeit das Start und Zieldatum ändern kann?

Außerdem suche ich noch nach einer Lösung, die verbundenen Zellen zu zentrieren ;)


Sub verbbindeZellen()
Dim Spalte As Integer
Dim Startspalte As Integer
Dim Endspalte As Integer
Dim Wert As Variant
Dim X As Integer
Const Maxspalte As Integer = 100
 
Dim Arbeitsblatt As Worksheet

Startspalte = 1
Set Arbeitsblatt = ThisWorkbook.ActiveSheet
With Arbeitsblatt
For Spalte = 1 To Maxspalte
If Cells(10, Spalte) <> Wert Then
Endspalte = Spalte - 1
If Startspalte < Endspalte And Wert <> "" Then
For X = Startspalte + 1 To Endspalte
Cells(10, X).Value = ""
Next X
Range(Cells(10, Startspalte), Cells(10, Endspalte)).Merge
End If
Startspalte = Spalte
Wert = Cells(10, Spalte).Value
End If
Next Spalte
End With

End Sub


Vielen Dank
Andi

Answer 1

Hallo Andi,

leider kann ich aus deiner Anfrage nicht herauslesen was du eigentlich willst. Ich verstehe nur, dass du Zellen verbinden willst. Aber welche?
Nutze bei der Anfrage bitte auch die richtigen Begriffe:
[quote]in Zeile A steht das Datum (z.B. A1: 01.01.18, A2: 02:01.18, usw.)[/quote]
Es muss heißen Spalte A (nur zur Klarstellung; bei Problembeschreibungen kann es verwirren, wenn Spalten und Zeilen vertauscht werden).

Mit deinem geposteten Makro werden ja nur Spalten in Zeile 10 verbunden. Das dürfte ja für dich nicht ausreichen.

Wenn du das Datum änderst, musst du natürlich erst sämtliche verbundene Zellen lösen, bevor du aufgrund des neuen Datums die Zellen wieder verbinden kannst.

Kannst du bitte das Problem noch einmal so erläutern, dass es auch jemand versteht, der weder weiß was du willst noch deine Tabelle kennt? Es wäre auch gut, wenn du eine Beispieltabelle auf einem Hoster deiner Wahl, z.B. [url=http://www.filehorst.de/]hier[/url], einstellen und den Link dann hier posten könntest.

Gruß

M.O.

Answer 2

Hallo M.O.
berechtigter und richtiger Einwand... ich war wohl gestern etwas verwirrt :)

Also:

In Zeile 1 steht fortlaufend in jeder Spalte das Datum (z.B. A1: 01.01.18, B1: 02.01.18, C1: 3.1.18, usw. bis Ende 2019)

In [b]Zeile 2[/b] steht das zugehörige [b]Jahr[/b] (A2: 2018, B2: 2018, usw.)

In [b]Zeile 3 [/b]steht der zugehörige [b]Monat [/b](A3: Januar, B3: Januar, usw.)

In [b]Zeile 4[/b] steht die zugehörige [b]KW[/b] (A4: 1, B4: 1, usw.)

Die jeweiligen Zeilen werden automatisch befüllt nachdem ich ein Start- und Enddatum festlege.

Jetzt stehen natürlich in den Zeilen 2 - 4  365 mal das jeweilige Jahr, +/- 30 mal der Monat und 7 mal die selbe KW nebeneinander.

Mit dem o.g. Code kann ich (angepasst auf Zeile 2, 3 und 4 anstatt 10) die identischen Zeilen zusammenfassen. Das funktioniert auch soweit ganz gut, nur sobald ich das Datum ändere, passen die verbundenen Zellen nicht mehr 100%ig. Denn auch wenn ich die Verbindung vorher löse, sind die Informationen (fortlaufende KW zum zugehörigen Datum, etc.) in einzelnen Zellen verloren.

Meine Lösung (die hoffentlich funktioniert) wäre jetzt, die Zeilen 2 - 4 so stehen zu lassen und in neue Zeilen kopieren zu lassen, um dann erst die identischen Zellen verbinden zu lassen.

Das heißt, das Makro müsste so angepasst werden, dass es nicht mehr die identischen Zellen in den Zeilen 2, 3 und 4 verbindet, sondern die Zeilen in neue Zeilen 6, 7 und 8 kopiert und dann erst verbindet. Am Besten natürlich in einem Makro (nicht wie aktuell 3) und statt nur zu verbinden auch den Text zentriert :).

Ich hoffe, das ist so verständlich. Hochladen kann ich leider im Moment nichts.

Grüße
Andi

Answer 3

Hallo Andi,

wenn du das Datum ändern willst, dann gehe wie folgt vor:

1. Löse die bestehenden Zellenverbindung mit dem folgenden Makro:
[code]Sub Verbindung_loesen()
Dim lngZeile As Long
Dim lngSpalte As Long
Dim rngZelle As Range
Dim Inhalt As Variant
Dim bFormel As Boolean

'Zeilen 2 bis 4 durchlaufen
For lngZeile = 2 To 4
  'letzte Spalte ermitteln
  lngSpalte = ActiveSheet.Cells(lngZeile, Columns.Count).End(xlToLeft).Column
  'Zellen durchlaufen
  For Each rngZelle In Range(Cells(lngZeile, 1), Cells(lngZeile, lngSpalte))
   bFormel = False         'Schalter für Formel auf falsch setzen
   'Prüfen, ob Zelle verbunden ist
   With rngZelle.MergeArea
     If .MergeCells Then
      'Prüfen, ob Formel in Zelle steht
      If .Cells(1).HasFormula Then
        bFormel = True                  'falls ja, Schalter für Formel
        Inhalt = .Cells(1).Formula      'Formel in Variable schreiben
       Else
        Inhalt = .Cells(1).Value         'sonst Wert übernehmen
      End If
     'Verindung auflösen
      .UnMerge
      If bFormel = True Then
       .Formula = Inhalt                'Formel in Zellen übertragen
      Else
       .Value = Inhalt                     'Wert in Zellen übertragen
      End If
     
     End If
    End With
  Next rngZelle
 Next lngZeile
 
End Sub[/code]
2. Ändere das Datum
3. Stelle die Verbindungen mit dem folgenden Makro her:
[code]Sub Zellen_verbinden()
Dim Spalte As Long
Dim Startspalte As Long
Dim Endspalte As Long
Dim Maxspalte As Long
Dim lngZeile As Long

With Application
.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
.EnableEvents = False 'Ereignisse
.Calculation = xlCalculationManual 'automatische Berechnuns ausschalten
.DisplayAlerts = False             'keine Meldungen anzeigen
End With

With ActiveSheet
'Zeilen 2 bis 4 durchlaufen  
For lngZeile = 2 To 4
   Maxspalte = .Cells(lngZeile, Columns.Count).End(xlToLeft).Column + 1
   Startspalte = 1
  
    'Spalten durchlaufen
    For Spalte = 2 To Maxspalte
     If .Cells(lngZeile, Spalte).Value <> .Cells(lngZeile, Startspalte).Value Then
        Endspalte = Spalte - 1
        If Startspalte < Endspalte Then
          With .Range(Cells(lngZeile, Startspalte), Cells(lngZeile, Endspalte))
           .HorizontalAlignment = xlCenter
           .Merge
          End With
        End If
      Startspalte = Spalte
     End If
   Next Spalte
  Next lngZeile
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With

End Sub[/code]
Gruß

M.O.

Answer 4

Hallo M.O.

vielen Dank für die Mühe.
Leider ist bei mir noch ein Fehler, den ich nicht finden kann. Es werden aktuell nur die Spalten in der 4. Zeile verbunden, die Zeilen 2 und 3 bleiben unberücksichtigt. Wahrscheinlich nur eine Kleinigkeit.

Und noch eine Frage: können die beiden Makros auch als ein Makro ausgeführt werden? Nach einem kurzen Test hat es zumindest funktioniert, das Datum zu ändern und dann beide Makros auszuführen.

Grüße
Andi

Answer 5

Hallo Andi,

bei meinen Tests wurden alle Spalten in den Zeilen 2 bis 4 zusammengefasst. Warum es bei dir nicht klappt, kann ich ohne die Tabelle nicht feststellen.

Natürlich kann man die Makros auch zusammenfassen. Zuerst auflösen und dann neu verbinden:

[code]Sub Verbinden_u_loesen()
Dim lngZeile As Long
Dim lngSpalte As Long
Dim rngZelle As Range
Dim Inhalt As Variant
Dim bFormel As Boolean
Dim Startspalte As Long
Dim Endspalte As Long
Dim Maxspalte As Long

With Application
.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
.EnableEvents = False 'Ereignisse
.Calculation = xlCalculationManual 'automatische Berechnuns ausschalten
.DisplayAlerts = False             'keine Meldungen anzeigen
End With

'Zeilen 2 bis 4 durchlaufen
For lngZeile = 2 To 4
  'letzte Spalte ermitteln
  lngSpalte = ActiveSheet.Cells(lngZeile, Columns.Count).End(xlToLeft).Column
  'Zellen durchlaufen
  For Each rngZelle In Range(Cells(lngZeile, 1), Cells(lngZeile, lngSpalte))
   bFormel = False         'Schalter für Formel auf falsch setzen
   'Prüfen, ob Zelle verbunden ist
   With rngZelle.MergeArea
     If .MergeCells Then
      'Prüfen, ob Formel in Zelle steht
      If .Cells(1).HasFormula Then
        bFormel = True                  'falls ja, Schalter für Formel
        Inhalt = .Cells(1).Formula      'Formel in Variable schreiben
       Else
        Inhalt = .Cells(1).Value         'sonst Wert übernehmen
      End If
     'Verindung auflösen
      .UnMerge
      If bFormel = True Then
       .Formula = Inhalt                'Formel in Zellen übertragen
      Else
       .Value = Inhalt                     'Wert in Zellen übertragen
      End If
     
     End If
    End With
  Next rngZelle
 Next lngZeile
 
 'nun wieder die Spalten verbinden
 With ActiveSheet
'Zeilen 2 bis 4 durchlaufen
For lngZeile = 2 To 4
   Maxspalte = .Cells(lngZeile, Columns.Count).End(xlToLeft).Column + 1
   Startspalte = 1
  
    'Spalten durchlaufen
    For Spalte = 2 To Maxspalte
     If .Cells(lngZeile, Spalte).Value <> .Cells(lngZeile, Startspalte).Value Then
        Endspalte = Spalte - 1
        If Startspalte < Endspalte Then
          With .Range(Cells(lngZeile, Startspalte), Cells(lngZeile, Endspalte))
           .HorizontalAlignment = xlCenter
           .Merge
          End With
        End If
      Startspalte = Spalte
     End If
   Next Spalte
  Next lngZeile
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
  
End Sub[/code]

Gruß

M.O.