01.08.2016, 10:07 (Dieser Beitrag wurde zuletzt bearbeitet: 01.08.2016, 10:12 von bsgVeritas.)
Hallo liebes Forum,
mein Problem stellt sich wie folgt da. Ich habe eine größere Excelliste mit mehreren Datensätzen (Zeilen) und Spalten (versch Attribute).
In einigen Datensätzen also Zeilen stehen in einer Spalte mit der Funktion: (ALT+Enter) also mit dem Zeilenumbruch getrennt mehrere Wörter.
Für jedes Dieser Wörter würde ich gern eine neue Zeile angelegt haben mit den gleichen Einträgen der Attribute wie in der Ursprungszeile wo sie herkommen. Zur veranschlaulischung meines Problems lade ich mal ein Bild und eine Beispieldatei hoch.
Meine konkrete Frage ist jetzt hier kann man dies einfacher hinbekommen als manuelle über Zelle kopierne (in der die Wörter untereinander stehen), dann mit "Text in Spalten" --> bei trennen "Alt Enter 101" angeben. Dann manuell die Ursprungszeile so oft kopieren wie das wort vorkommt und die geänderten Spalten (attribute) ergänzen.?!
Bild:
[url= Dateiupload bitte im Forum! So geht es: Klick mich! ]
Datei:
(01.08.2016, 12:03)bsgVeritas schrieb: Ist das mit excel vielleicht so einfach nicht möglich und kommt an vba nicht vorbei ?
Kann das einer schon sagen ? Ich versuchs mal mit makro aufzeichnen ..
Code:
Option Explicit
Sub AltEnterSplit()
Dim sInp() As String
Dim sTeileNr() As String
Dim sAnz() As String
Dim delLineNo() As Long
Dim rg As Range
Dim cell As Range
Dim rgBezeichnung As Range
Dim wks As Worksheet
Dim i As Integer, j As Integer
Dim newLine As Range
Dim oldLine As Range
Const ListWidth = 17
Const colBez = 8
On Error GoTo AltEnterSplit_Error
' If neceessary adjust codename of worksheet
Set wks = Tabelle1
Set rgBezeichnung = wks.Range(wks.Cells(2, colBez), wks.Cells(2, colBez).End(xlDown))
j = 0
Application.ScreenUpdating = False
For Each cell In rgBezeichnung
sInp = Split(cell.Value, vbLf)
If LBound(sInp) = UBound(sInp) Then
' Do nothing
Else
' add as many new lines as entries in the array
For i = LBound(sInp) To UBound(sInp)
' Add single line
Set rg = Range("A1").End(xlDown).Offset(1, 0)
Set newLine = wks.Range(rg, wks.Cells(rg.Row, ListWidth))
Set oldLine = wks.Range(Cells(cell.Row, 1), wks.Cells(cell.Row, ListWidth))
newLine.Value = oldLine.Value
newLine.Cells(1, colBez).Value = sInp(i)
' If adjacent cells don't have the same number of lines just ignore it
On Error Resume Next
newLine.Cells(1, colBez - 1).Value = sTeileNr(i)
newLine.Cells(1, colBez + 1).Value = sAnz(i)
On Error GoTo AltEnterSplit_Error
Next i
' Collect the line to delete
ReDim Preserve delLineNo(j)
delLineNo(j) = cell.Row
j = j + 1
End If
Next cell
For i = UBound(delLineNo) To LBound(delLineNo) Step -1
Rows(delLineNo(i)).Delete
Next
On Error GoTo 0
Exit Sub
AltEnterSplit_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AltEnterSplit of Modul Modul1"