Zellen gleichen Inhalts verbinden und Ergebnis zentrieren

Question

Ich habe eine Tabelle mit 11 Spalten. Die Zellen füllen sich bei jedem Mal, wenn das Makro ausgeführt wird, mit anderen Werten. Ich möchte, dass das Makro am Ende jede Spalte nacheinander prüft und Zellen, die den gleichen Wert enthalten verbindet. Der Wert soll im Anschluss in der Verbundzelle zentriert angezeigt werden.

Answer 1

Hallo,

wie schon geschrieben, würde ich den Fehler bei der Quelle angehen.
Also statt z.B.
=SVERWEIS(A14;H15:I19;2;FALSCH)
würde ich die Formel
=WENNFEHLER(SVERWEIS(A14;H15:I19;2;FALSCH);"")
nutzen, so dass erst überhaupt keine Fehlermeldung im Blatt angezeigt wird.

Wenn du das mit dem Makro lösen willst, würde ich das so machen (wenn du nur den Bereich A10:F33 durchsuchen willst:

Dim zell As Range
For Each zell In Range("A10:F33")
If zell.Text = "#NV" Then zell.ClearContents
'oder so, falls auch andere Fehleranzeigen gelöscht werden sollen
'If IsError(zell.Value) = True Then zell.ClearContents
Next zell

oder du ergänzt das Makro zum Kopieren und Verbinden entsprechend:

Sub verbinden()

Dim lngletzte As Long
Dim lngZeile As Long
Dim lngSpalte As Long
Dim lngAnfang As Long
Dim varInhalt As Variant
Dim strQuelle As String
Dim strPfad As String
Dim strZiel As String
Dim strName As String

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Benachrichtigungen ausschalten
Application.DisplayAlerts = False

'Name der aktuellen Datei in Variable schreiben
strQuelle = ThisWorkbook.Name

'Name für neue Datei in Variable einlesen
strZiel = ThisWorkbook.Worksheets("XXX").Range("C10") & ".xlsx"

'Arbeitsblatt XXX in neue Datei verschieben
Workbooks(strQuelle).Worksheets("XXX").Copy

'Name des neuen Workbooks in Variable schreiben
strName = ActiveWorkbook.Name

For lngSpalte = 1 To 11 'für Spalten A bis K
lngletzte = Workbooks(strName).Worksheets("XXX").Cells(Rows.Count, lngSpalte).End(xlUp).Row + 1 'letzte Zeile in Spalte ermitteln und um 1 erhöhen
If IsError(varInhalt = Workbooks(strName).Worksheets("XXX").Cells(1, lngSpalte).Value) = False Then
varInhalt = Workbooks(strName).Worksheets("XXX").Cells(1, lngSpalte) 'Inhalt der ersten Zeile in Variable schreiben
Else
varInhalt = ""
End If

lngAnfang = 10 'erste Zeilennummer in Variable schreiben

For lngZeile = 10 To lngletzte
If IsError(Workbooks(strName).Worksheets("XXX").Cells(lngZeile, lngSpalte).Value) = False Then
If CVar(Workbooks(strName).Worksheets("XXX").Cells(lngZeile, lngSpalte)) <> varInhalt Then
If lngZeile - lngAnfang > 1 Then
With Workbooks(strName).Worksheets("XXX").Range(Cells(lngAnfang, lngSpalte), Cells(lngZeile - 1, lngSpalte))
.MergeCells = True
.VerticalAlignment = xlCenter
End With
End If
varInhalt = Workbooks(strName).Worksheets("XXX").Cells(lngZeile, lngSpalte).Value
lngAnfang = lngZeile
End If
End If
Next lngZeile
Next lngSpalte

'Pfad anpassen
strPfad = "W:\ki\ek\wfl\vz-dispo\Importsteuerung\Lieferschein-delivery notes\Lieferscheinexport Makro\" & strZiel

Workbooks(strName).SaveAs Filename:=strPfad

'drucken
Workbooks(strZiel).Worksheets("XXX").PrintOut Copies:=1

'neue Datei schließen - ohne speichern von Änderungen
Workbooks(strZiel).Close (False)

Workbooks(strQuelle).Worksheets("Quelldaten").Activate
Range("A3").Select

'Benachrichtigungen einschalten
Application.DisplayAlerts = True

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 2

Ich habe jetzt die SVerweise alle umgeschrieben. Das ist ja wohl die einfachere Lösung. Manchmal sind man den Wald vor lauter Bäumen nicht.

Ich habe jetzt aber immernoch das Problem, dass mir dein Marko zum Verbinden der Zellen, meinen "Überschriftenbereich" Zeilte 1 bis 9 schrottet. Da sieht nach dem Ausführen des Makros nichts mehr aus wie vorher.

Answer 3

Hallo,

meine letzten geposteten Makros können eigentlich dafür nicht verantwortlich sein, da sie erst ab der Zeile 10 beginnen die Spalten zu durchsuchen:
For lngZeile = 10 To lngletzte

Ändere auch mal die folgende Zeile ab (hatte ich vergessen entsprechend anzupassen):

varInhalt = Workbooks(strName).Worksheets("XXX").Cells(1, lngSpalte)

in

varInhalt = Workbooks(strName).Worksheets("XXX").Cells(10, lngSpalte)

Prüfe also mal, ob in deinem verwendeten Makro diese Zeile stimmt.

Gruß

M.O.

Answer 4

Hi,

ich habe jetzt noch ein wenig mit deinem Makro rumprobiert (da lerne ich ja dann auch wenigstens was dabei) und habe es jetzt final hinbekommen. Jetzt funzt wirklich alles exakt so, wie ich mir das vorgestellt hatte. Anbei nochmal wie ich geändert hatte.

' Zellen mit gleichem Inhalt verbinden Spalte 1 - 6


Dim lngletzte As Long
Dim lngZeile As Long
Dim lngSpalte As Long
Dim lngAnfang As Long
Dim varInhalt As Variant

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Benachrichtigungen ausschalten
Application.DisplayAlerts = False

' für Spalten A bis C
For lngSpalte = 1 To 3

' letzte Zeile in Spalte ermitteln und um 1 erhöhen
lngletzte = ActiveSheet.Cells(Rows.Count, lngSpalte).End(xlUp).Row + 1

'Inhalt der ersten Zeile in Variable schreiben
varInhalt = ActiveSheet.Cells(10, lngSpalte)

'erste Zeilennummer in Variable schreiben
lngAnfang = 10

' für Zeilen 10 bis 33
For lngZeile = 10 To 33
If ActiveSheet.Cells(lngZeile, lngSpalte).Value <> varInhalt Then
If lngZeile - lngAnfang > 1 Then
With ActiveSheet.Range(Cells(lngAnfang, lngSpalte), Cells(lngZeile - 1, lngSpalte))
.MergeCells = True
.VerticalAlignment = xlCenter
End With
End If
varInhalt = ActiveSheet.Cells(lngZeile, lngSpalte).Value
lngAnfang = lngZeile
End If
Next lngZeile
Next lngSpalte


' Zellen mit gleichem Inhalt verbinden Spalte 11 - 12

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Benachrichtigungen ausschalten
Application.DisplayAlerts = False


Habe ein paar wenige Sachen einfach angepasst und siehe da es hat funktioniert. Ein Leihe wie ich kann nun nur noch nicht erklären, was durch die Änderungen konkret passiert ist. Dennoch jetzt nochmal vielen lieben Dank für Deine unerschöpflich geduldige Hilfe