Spalten einfügen / Text in Zeile (ohne zu überschreiben)

jerry0110

Erfahrenes Mitglied
Hi,

ich habe folgendes Problem. Ich möchte in einer Exceltabelle folgende Dinge tun.

Nach einer Überschrift suchen und dann in dieser Spalte dann den Umbruch entfernen und ein "|" einfügen. Dann soll diese Spalte dann in 3 oder 4 Spalten aufgeteilt werden, ohne das die recht neben liegenden Spalten überschrieben werden.

Dann möchte ich, dass am Anfang der Tabelle 3 Spalten eingefügt werden, die auch direkt mir einer Überschrift versehen werden.

Ich habe viele Sachen jetzt seit Tagen durchsucht und ausprobiert. Das einziege was wirklich läuft ist das was ich jetzt schon habe. Aber das ist halt nur das Suchen. Rest halt nicht.

Sub Makro()
With Columns(Application.Match("X", Rows(1), 0))
.Replace Chr(10), "|"
End With


With Columns(Application.Match("Y", Rows(1), 0))
.Replace What:="Herr", Replacement:="Herrn", LookAt:=xlPart
End With

With Columns(Application.Match("Z", Rows(1), 0))
.Replace Chr(10), "; "
End With

End Sub


Bei X steht ich jetzt vor dem Problem, dies zu lösen. Bei Y und Z läuft alles so wie ich es will.

Danke schon mal

Grüße
 

Yaslaw

n/a
Moderator
Hier mal ein schneller entwurf

Visual Basic:
Public Sub test()
    Dim ws As Worksheet: Set ws = ActiveWorkbook.Worksheets("Sheet1")
    Dim maxParts As Long
    Dim rowNr As Long
    Dim parts() As String
    Dim col As Range
    Dim colNrDelta As Long
    
    'Spalte auswählen
    Set col = ws.Columns(Application.Match("X", Rows(1), 0))
    
    'Den Replace durchführen
    col.Replace Chr(10), "|"
    
    'Anzahl neuer Spalten ermitteln. Massgebend ist das Feld mit den meisten |
    For rowNr = 2 To xlsGetLastRow(ws)
        parts = Split(ws.Cells(rowNr, col.column), "|")
        If UBound(parts) + 1 > maxParts Then maxParts = UBound(parts) + 1
    Next rowNr
        
    'Spalten hinzufügen
    For colNrDelta = 1 To maxParts
        ws.Columns(col.column + 1).Insert xlShiftToRight
    Next colNrDelta
    
    'Neue Felder abfüllen
    For rowNr = 2 To xlsGetLastRow(ws)
        parts = Split(ws.Cells(rowNr, col.column), "|")
        For colNrDelta = 1 To UBound(parts) + 1
            ws.Cells(rowNr, col.column + colNrDelta).Value = parts(colNrDelta - 1)
        Next colNrDelta
    Next rowNr
    
    Set col = Nothing
    Set ws = Nothing
    
End Sub
 

jerry0110

Erfahrenes Mitglied
Hi,

danke erstmal für die Schnelle hilfe.

Der Umbruch ist unter der Überschrift und enthält Firmennamen die durch den Umbruch getrennt sind.

Habe jetzt deine Programmierung eingefügt und versucht das Makro zu starten.
Leider bekomme ich immer den Fehler das der Sub oder die Funktion nicht definiert wurde.
Und im Debugger wird "xlsGetLastRow" markiert und Public Test wird gelb unterlegt.
 

Yaslaw

n/a
Moderator
Sorry, mein Fehler. Dir fehlt da noch eine Funktion...
http://wiki.yaslaw.info/dokuwiki/doku.php/vba/excel/functions/getlastrowcol

Visual Basic:
'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet   Das Worksheetobjekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
   
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.Rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function
 

jerry0110

Erfahrenes Mitglied
Hi,

danke hat alles geklappt. :)

Gibt es auch eine Möglichkeit, die Überschriften für die neu erstellten direkt mit anzulegen?
z. B. Name1 - Name(x) so viele Spalten wie angelegt werden?
 

Yaslaw

n/a
Moderator
Jepp. Ersetze den Spalten-hinzufügen-Abschnitt
Code:
    'Spalten hinzufügen und Titel setzen
    For colNrDelta = maxParts To 1 Step -1
        ws.Columns(col.column + 1).Insert xlShiftToRight
        ws.Cells(1, col.column + 1).Value = ws.Cells(1, col.column).Value & "(" & colNrDelta & ")"
    Next colNrDelta
 

Neue Beiträge