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,

wenn du die Tabelle immer wieder per Makro mit neuen Werten füllst, würde ich das Verbinden von Zellen unterlassen, da es sonst z.B. bei einem neuen Import zu Problemen kommen kann.

Gruß

M.O.

Answer 2

Das Makro läuft bisher ohne Probleme. Die Tabelle wird exportiert und wieder in die Ursprungsformatierung zurückgesetzt. Deshalb gibt es keine Probleme, wenn wieder neue Daten eingefügt werden.

Ich möchte allerdings vor dem Export, dass Verbundzellen erstellt werden, damit die Tabelle übersichtlicher ist.

Answer 3

Hallo,

habe ich das richtig verstanden, wenn zwei oder mehr Zellen in einer Spalte untereinander den selben Wert haben, dann sollen diese Zellen verbunden werden?

Gruß

M.O.

Answer 4

Hallo.

Genau. Jeweils die Zellen, untereinander, mit jeweils gleichem Wert
sollen verbunden werden. Und das ganze für jeweils 11 Spalten in der
besagten Tabelle.

Zum Schluss noch alle Werte zentrieren.

Answer 5

Hallo,

schau mal, ob das so wie du willst funktioniert:

Sub verbinden()

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

For lngSpalte = 1 To 11 'für Spalten A bis K
lngletzte = ActiveSheet.Cells(Rows.Count, lngSpalte).End(xlUp).Row + 1 'letzte Zeile in Spalte ermitteln und um 1 erhöhen
varInhalt = ActiveSheet.Cells(1, lngSpalte) 'Inhalt der ersten Zeile in Variable schreiben
lngAnfang = 1 'erste Zeilennummer in Variable schreiben

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

'Benachrichtigungen einschalten
Application.DisplayAlerts = True

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 6

ich bekomme Laufzeitfehler "13"
Typen unverträglich

an dieser Stelle:

If ActiveSheet.Cells(lngZeile, lngSpalte).Value <> varInhalt Then

Answer 7

Hallo,

ersetze das mal durch die Zeile

If ActiveSheet.Cells(lngZeile, lngSpalte) <> varInhalt Then

Gruß

M.O.

Answer 8

Hallo,

ich habe den ersten Code auf einer neu erstellten Tabelle angewendet und das funktioniert super. Da ich bei meinem bestehenden Makro die Tabelle, bei der ich die Zellen verbinden möchte vor dem Abspeichern und Ausdrucken ausgelagert wurde als neues Tabellenblatt mit dem Namen XXX, gibt es einen Laufzeitfehler.

Wie muss ich den ersten code umschreiben, dass er auf Arbeitsmappe xxx angewand wird?

Answer 9

Hallo,

ersetze

ActiveSheet

durch

Workbooks("Mappe1.xlsx").Worksheets("Tabelle1")

Die Namen "Mappe1" und "Tabelle1" musst du natürlich durch die Namen deiner Arbeitsmappe und deines Tabellenblatts ersetzen.

Gruß

M.O.

Answer 10

Also ich will ja nicht lästig werden, aber ich sitze völlig auf der Leitung.

Ich habe eine Excelarbeitsmappe mit 2 Tabellenblättern. Tabellenblatt 1 heißt &quot;Quelldaten&quot;. Hier kopiere ich wie der Name schon sagt, meine Quelldaten rein.

Tabelleblatt 2 heißt XXX. In diesm Tabellenblatt werden die &quot;Quelldaten&quot; per Formeln von &quot;Quelldaten&quot; auf bestimmte Positionen in &quot;XXX&quot; übertragen.

Nun starte ich das Makro, welches derzeit folgendes tut:

1. Tabellenblatt &quot;XXX&quot; kopieren als neue &quot;Arbeitsmappe.
2. nun sollen alle gleichen Werte der 11 Spalten verbunden und zentriert werden
3. das zuvor kopierte Tabellenblatt wird nun unter einem bestimmten Pfad abgelegt, wobei der Name der Datei hier dem Inhalt von Zelle &quot;C10&quot; entspricht
4. kopiertes Tabellenblatt wird gedruck und geschlossen
5. springen in die Excelarbeitsmappe in Tabellenblatt &quot;Quelldaten&quot; auf Pos. A3

Makro beendet

Anbei mein Quellcode:
__________________________________________________________________
Sub Test4()
&#39;
&#39; Test4 Makro
&#39;

&#39;
    Sheets(&quot;XXX&quot;).Select
    ActiveCell.Offset(6, 0).Range(&quot;A1&quot;).Select
    ActiveWindow.SmallScroll Down:=-15
    ActiveCell.Offset(-6, 0).Range(&quot;A1:L1&quot;).Select
    Sheets(&quot;XXX&quot;).Select
    Sheets(&quot;XXX&quot;).Copy
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = &quot;&quot;
        .PrintTitleColumns = &quot;&quot;
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = &quot;$A$1:$L$37&quot;
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = &quot;&quot;
        .CenterHeader = &quot;&quot;
        .RightHeader = &quot;&quot;
        .LeftFooter = &quot;&quot;
        .CenterFooter = &quot;&quot;
        .RightFooter = &quot;&quot;
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = &quot;&quot;
        .EvenPage.CenterHeader.Text = &quot;&quot;
        .EvenPage.RightHeader.Text = &quot;&quot;
        .EvenPage.LeftFooter.Text = &quot;&quot;
        .EvenPage.CenterFooter.Text = &quot;&quot;
        .EvenPage.RightFooter.Text = &quot;&quot;
        .FirstPage.LeftHeader.Text = &quot;&quot;
        .FirstPage.CenterHeader.Text = &quot;&quot;
        .FirstPage.RightHeader.Text = &quot;&quot;
        .FirstPage.LeftFooter.Text = &quot;&quot;
        .FirstPage.CenterFooter.Text = &quot;&quot;
        .FirstPage.RightFooter.Text = &quot;&quot;
    End With
    
&#39; Lieferschein drucken
    
    Application.PrintCommunication = True
    ActiveWindow.SmallScroll Down:=-6
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False

&#39; Lieferschein speichern

    ChDir _
        &quot;W:&#92;ki&#92;ek&#92;wfl&#92;vz-dispo&#92;Importsteuerung&#92;Lieferschein-delivery notes&#92;Lieferscheinexport Makro&quot;
    ActiveWorkbook.SaveAs &quot;W:&#92;ki&#92;ek&#92;wfl&#92;vz-dispo&#92;Importsteuerung&#92;Lieferschein-delivery notes&#92;Lieferscheinexport Makro&#92;&quot; _
    &amp; Range(&quot;C10&quot;) &amp; (&quot;.xlsx&quot;), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Sheets(&quot;Quelldaten&quot;).Select
    

    
End Sub

__________________________________________

Wo und wie muss ich jetzt Deinen Code einfügen, dass das so funktioniert, wie ich mir das vorstelle?