Code von Ehrensberger

Hallo Sepp, hallo Excel Profis,
am 26.7. hast Du mir freundlicherweise den Code unter dem Namen "split35" zukommen lassen.
Bis jetzt hat das auch fast immer funktioniert.
Jetzt habe ich aber folgenden Text bekommen, bei dem unschön die letzten 3 Buchstaben "ren" in die nächste Zelle aufgesplittet werden:
RE 046-011 v. 18.7.2011 Maklergebühren
Da ich den Code immer noch nicht verstehe, kann ich das Problem nicht selbst lösen.
Ich hoffe Du oder jemend anders von den Profis können mir dabei helfen.
Auf jeden Fall vielen Dank im voraus für die Unterstützung.
Hier nochmal die Aufgabenstellung und der Code von J. Ehrensberger:
Ich muss regelmäßig eine Excel-Tabelle mit mehreren Spalten und Zeilen Inhalt in eine CSV-Datei per VBA umwandeln.
Das krieg ich bis auf folgende Herausforderung ohne Probleme hin:
In einer Spalte der Excel-Tabelle darf Text bis zu 140 Stellen eingegeben werden. In der CSV-Datei dürfen aber dafür nur 4 Spalten mit einer maximalen Breite von 35 Stellen vorkommen.
Folgender Beispieltext soll aber so aufgeteilt werden, dass Wörter nicht auseinandergerissen werden, sondern nach einer Leerstelle mit der jeweils neuen Spalte begonnen wird.
"Dies ist ein x-beliebiger Beispieltext, der aus insgesamt 112 Zeichen (inkl. Satzzeichen + Leerstellen) besteht."
In jedem Datensatz steht natürlich jeweils ein anderer Text.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit


Sub split35()
Dim rng As Range, rngF As Range
Dim strText As String, strTmp As String
Dim lngPos As Long, lngOffset As Long
Const MAXLENGTH As Long = 35
On Error GoTo ErrExit
Application.ScreenUpdatingfalse
Set rngF = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'Beispiel für Spalte A
For Each rng In rngF
If Len(rng.Text) Then
lngOffset = 0
strText = rng.Text
Do While Len(strText) And lngOffset  MAXLENGTH Then
strTmp = Trim$(Left(strText, InStrRev(Left(strText, 35), " ", MAXLENGTH - 1)))
Else
strTmp = Trim(Left(strText, MAXLENGTH))
End If
rng.Offset(0, lngOffset) = strTmp
lngOffset = lngOffset + 1
strText = Trim$(Mid(strText, Len(strTmp) + 1))
Loop
End If
Next
ErrExit:
Application.ScreenUpdating = True
Set rng = Nothing
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub split35() Dim rng As Range, rngF As Range Dim strTmp As String Dim lngIndex As Long Dim vntTMP As Variant Const MAXLENGTH As Long = 35 On Error GoTo ErrExit Application.ScreenUpdating = False Set rngF = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'Beispiel für Spalte A For Each rng In rngF If Len(rng.Text) Then strTmp = breakText(rng.Text, MAXLENGTH) If InStr(1, strTmp, vbLf) > 0 Then vntTMP = Split(strTmp, vbLf) For lngIndex = 0 To UBound(vntTMP) rng.Offset(0, lngIndex) = vntTMP(lngIndex) Next End If End If Next ErrExit: Application.ScreenUpdating = True Set rng = Nothing End Sub Private Function breakText(ByVal theText As String, ByVal breakLength As Long) As String Dim strTmp As String, strOut As String Dim intLength As Integer, intN As Integer, intM As Integer theText = Replace(theText, vbLf, " ") intLength = Len(theText) intM = 1 intN = 1 Do strTmp = Mid(theText, intN, breakLength) If intLength - intN >= breakLength Then intM = Len(strTmp) - InStr(1, StrReverse(strTmp), " ") + 1 Else intM = Len(strTmp) End If strOut = strOut & Trim(Left(strTmp, intM)) & vbLf intN = intN + intM Loop While intN < intLength breakText = Left(strOut, Len(strOut) - 1) End Function

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub split35() Dim rng As Range, rngF As Range Dim strTmp As String Dim lngIndex As Long Dim vntTMP As Variant Const MAXLENGTH As Long = 35 On Error GoTo ErrExit Application.ScreenUpdating = False Set rngF = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'Beispiel für Spalte A For Each rng In rngF If Len(rng.Text) Then strTmp = breakText(rng.Text, MAXLENGTH) If InStr(1, strTmp, vbLf) > 0 Then vntTMP = Split(strTmp, vbLf) For lngIndex = 0 To UBound(vntTMP) rng.Offset(0, lngIndex) = vntTMP(lngIndex) Next End If End If Next ErrExit: Application.ScreenUpdating = True Set rng = Nothing End Sub Private Function breakText(ByVal theText As String, ByVal breakLength As Long) As String Dim strTmp As String, strOut As String Dim intLength As Integer, intN As Integer, intM As Integer theText = Replace(theText, vbLf, " ") intLength = Len(theText) intM = 1 intN = 1 Do strTmp = Mid(theText, intN, breakLength) If intLength - intN >= breakLength Then If InStr(1, StrReverse(strTmp), " ") > 0 Then intM = Len(strTmp) - InStr(1, StrReverse(strTmp), " ") + 1 Else intM = breakLength End If Else intM = Len(strTmp) End If strOut = strOut & Trim(Left(strTmp, intM)) & vbLf intN = intN + intM Loop While intN < intLength breakText = Left(strOut, Len(strOut) - 1) End Function

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread