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

vielleicht sei noch erwähnt, dass der Bereich, für den die Zellen verbunden werden sollen, erst bei Zeile10 Anfang. Alles was drüber ist sind Überschriften, für die keine Verbindungen erstellt werden düfen.

Answer 2

Hallo,

versuch es mal so:

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
varInhalt = Workbooks(strName).Worksheets("XXX").Cells(1, lngSpalte) 'Inhalt der ersten Zeile in Variable schreiben
lngAnfang = 10 'erste Zeilennummer in Variable schreiben

For lngZeile = 10 To lngletzte
If 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
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

Den Druckbereich habe ich mal weggelassen. Achtung, eventuell vorhandene Arbeitsmappen mit gleichem Namen im Verzeichnis werden ohne Nachfrage und Hinweis überschrieben!

Gruß

M.O.

Answer 3

If Workbooks(strName).Worksheets("XXX").Cells(lngZeile, lngSpalte) <> varInhalt Then

an dieser Stelle kommt der erste Laufzeitfehler

Answer 4

Hallo,

bei mir läuft das Makro ohne Probleme. Welcher Laufzeitfehler kommt denn?

Gruß

M.O.

Answer 5

Lafzeitfehler 13

Typen unverträglich

Answer 6

Hallo,

versuch mal die folgende Version:

If CVar(Workbooks(strName).Worksheets("XXX").Cells(lngZeile, lngSpalte)) <> varInhalt Then

Gruß

M.O.

Answer 7

gleicher Fehler

Answer 8

Ich habe den Code 1:1 in mein Makro eingefügt und das alte komplett überschrieben. Hätte ich da noch irgendwas umschreiben müssen?

Answer 9

Hallo,

lade mal eine Testdatei mit ein paar Dummydaten, die aber im Aufbau deinen wirklichen Daten entsprechen, auf einen Hoster deiner Wahl (z.B. hier hoch und poste den Link hier im Forum.
Wie schon geschrieben funktioniert das Makro in meiner Testdatei ohne Probleme.

Gruß

M.O.

Answer 10

Das muss ich dann privat machen. Unser Admin sperrt den Link.