Microsoft Excel

Herbers Excel/VBA-Archiv

VBA Text umbauen

Betrifft: VBA Text umbauen von: Charly
Geschrieben am: 27.10.2012 11:11:42

Hallo
Hab mein Problem in dem Beispiel beschrieben.
Ich hoffe ihr könnt mir helfen?
Hier die Mappe

https://www.herber.de/bbs/user/82338.xls

Danke vorab
MfG Charly

  

Betrifft: AW: VBA Text umbauen von: Tino
Geschrieben am: 27.10.2012 11:51:38

Hallo,
kannst mal so versuchen.
Ergebnis wird in Spalte B ausgegeben.

Sub Daten_()
Dim ArrayData, NewArr(), tmpArr, n&, nn&
With Tabelle1 'Tabelle evtl. anpassen
ArrayData = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
Redim Preserve NewArr(1 To Ubound(ArrayData), 1 To 1)

For n = 1 To Ubound(ArrayData)
ArrayData(n, 1) = Replace(ArrayData(n, 1), " ", "")
If Len(ArrayData(n, 1)) > 4 Then
tmpArr = Split(ArrayData(n, 1), ".")
If Ubound(tmpArr) > 1 Then
nn = nn + 1
NewArr(nn, 1) = Format(tmpArr(0), "00") & "."
NewArr(nn, 1) = NewArr(nn, 1) & Format(tmpArr(1), "00") & "."
NewArr(nn, 1) = NewArr(nn, 1) & Format(tmpArr(2), "0000")
End If
End If
Next n
.Range("B1").Resize(.Rows.Count).Clear 'alte Daten löschen
.Range("B1").Resize(nn) = NewArr 'neue Daten einfügen
End With
End Sub
Gruß Tino


  

Betrifft: Noch nicht ganz ... von: Charly
Geschrieben am: 27.10.2012 13:22:58

Hi Tino
... das was ich wollte.
Ich hatte nicht gesagt das die Folgespalten auch gefüllt sind
Mein Fehler!
Ich habs mal etwas angepasst, aber ... sh. im Code

Sub Daten_()
Dim ArrayData, NewArr(), tmpArr, n&, nn&
With Sheets(1)
    ArrayData = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
    ReDim Preserve NewArr(1 To UBound(ArrayData), 1 To 1)
    
    For n = 1 To UBound(ArrayData)
        ArrayData(n, 1) = Replace(ArrayData(n, 1), " ", "")
'Jetzt sollten die Zeilen mit weniger als 5 Zeichen in Spalte A gelöscht werden
'Hintergrund ist: in den folgenden Spalten steht auch noch was drin
        If Len(ArrayData(n, 1)) > 4 Then
            tmpArr = Split(ArrayData(n, 1), ".")
            If UBound(tmpArr) > 1 Then
                nn = nn + 1
                NewArr(nn, 1) = Format(tmpArr(0), "00") & "."
                NewArr(nn, 1) = NewArr(nn, 1) & Format(tmpArr(1), "00") & "."
                NewArr(nn, 1) = NewArr(nn, 1) & Format(tmpArr(2), "0000")
            End If
        End If
    Next n
    .Range("A1").Resize(.Rows.Count).Clear 'alte Daten löschen
    .Range("A1").Resize(nn) = NewArr 'neue Daten einfügen
End With
End Sub
Wenn du nochmal helfen könntest?
MfG Charly


  

Betrifft: AW: Noch nicht ganz ... von: Tino
Geschrieben am: 27.10.2012 13:49:36

Hallo,
die Daten werden in einem neuen Array gesammelt und nur die Daten aufgenommen
die mehr als 4 Zeichen haben.

Gruß Tino


  

Betrifft: Ja aber ... von: Charly
Geschrieben am: 27.10.2012 13:58:05

... nach dem Freizeichen löschen und
vor dem sammeln der Daten, sollten die Zeilen gelöscht werden,
wo in Spalte A weniger als 5 Zeichen vorhanden sind.

MfG Charly


  

Betrifft: AW: Ja aber ... von: Tino
Geschrieben am: 27.10.2012 14:51:01

Hallo,
nach dem zurückschreiben des neuen Array sind diese Daten nicht mehr vorhanden!

Gruß Tino


  

Betrifft: Oder ... von: Charly
Geschrieben am: 27.10.2012 14:14:15

... die bearbeiteten Daten aus dem ArrayData müssten an die selbe Position in Spalte A
geschrieben werden, und dann alle Zeilen die die in Spalte A ungleich 10 Zeichen
haben gelöscht werden.
Geht das?

MfG Charly


  

Betrifft: AW: Oder ... von: Tino
Geschrieben am: 27.10.2012 15:06:28

Hallo,
ach die komplette Zeile soll gelöscht werden?!
Versuchen wir es mal so.

Sub Daten_()
Dim ArrayData, tmpArr, tmpValue, n&
With Tabelle1 'Tabelle evtl. anpassen
ArrayData = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
For n = 1 To Ubound(ArrayData)
tmpValue = ArrayData(n, 1)
ArrayData(n, 1) = Empty
tmpValue = Replace(tmpValue, " ", "")
If Len(tmpValue) > 4 Then
tmpArr = Split(tmpValue, ".")
If Ubound(tmpArr) > 1 Then
tmpValue = Format(tmpArr(0), "00") & "."
tmpValue = tmpValue & Format(tmpArr(1), "00") & "."
tmpValue = tmpValue & Format(tmpArr(2), "0000")
ArrayData(n, 1) = tmpValue
End If
End If
Next n
.Range("A1").Resize(Ubound(ArrayData)) = ArrayData 'neue Daten einfügen
.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub
Gruß Tino


  

Betrifft: Klasse, genau so von: Charly
Geschrieben am: 27.10.2012 15:41:02

Danke Tino,
dass hilft mir viel weiter.

Schönes Wochenende
MfG Charly


  

Betrifft: AW: VBA Text umbauen von: Hajo_Zi
Geschrieben am: 27.10.2012 11:52:13

Hallo Charly,

zur Problembeschreibung ist der Beitrag da.
Nacuh dem betreff arbeite mit Left, Right und Mid

GrußformelHomepage


  

Betrifft: Hast ja Recht, Danke o.T. von: Charly
Geschrieben am: 27.10.2012 13:45:40

.


  

Betrifft: AW: VBA Text umbauen von: MatthiasG
Geschrieben am: 27.10.2012 11:55:45

Hallo Charly,

trotz Quick and Dirty war ich wohl zu langam.

Hier mein Vorschlag, ohne Fehlerprüfung:

Sub Umwandeln()
Const Spalte = 1, ZielSpalte = 3
Dim i As Integer
Dim lz As Long, z As Long, zarr
Dim z0 As String
Dim nz As Long

lz = Cells(Rows.Count, Spalte).End(xlUp).Row

For z = 1 To lz
    z0 = Replace(Cells(z, Spalte).Text, " ", "")
    If Len(z0) >= 5 Then
        zarr = Split(z0, ".")
        For i = LBound(zarr) To UBound(zarr)
            zarr(i) = "0000" & zarr(i)
        Next i
        zarr(0) = Right(zarr(0), 2)
        zarr(1) = Right(zarr(1), 2)
        zarr(2) = Right(zarr(2), 4)
        nz = nz + 1
        Cells(nz, ZielSpalte) = zarr(0) & "." & zarr(1) & "." & zarr(2)
    End If
    
Next z
End Sub
Gruß Matthias


  

Betrifft: AW: VBA Text umbauen von: Charly
Geschrieben am: 27.10.2012 13:50:32

Hallo Matthias
Danke für die schnelle Antwort
Funktioniert aber ... selbiges Problem wie bei Tino.
Könntest du bitte mal in meine Antwort bei Tino schauen.
Danke

MfG Charly


  

Betrifft: AW: VBA Text umbauen von: Gerd L
Geschrieben am: 27.10.2012 12:04:53

Hallo Charly,

noch ein Spielzeug.

Sub c()

Dim R As Range

Columns(1).Replace " ", "", xlPart
Columns(1).NumberFormat = "general"

For Each R In Columns(1).SpecialCells(xlCellTypeConstants)
If Len(R) > 5 Then
R.Value = Format(Split(R.Value, ".")(0), "00") & "." _
          & Format(Split(R.Value, ".")(1), "00") & "." _
          & Format(Split(R.Value, ".")(2), "0000")
Else
R.ClearContents
End If
Next
Columns(1).SpecialCells(xlCellTypeBlanks).Delete

End Sub

Gruß Gerd


  

Betrifft: AW: VBA Text umbauen von: Charly
Geschrieben am: 27.10.2012 14:23:13

Hallo Gerd
Bei deinem Code bekomme ich Laufzeitfehler 9
Markiert wird:
R.Value = Format(Split(R.Value, ".")(0), "00") & "." _
& Format(Split(R.Value, ".")(1), "00") & "." _
& Format(Split(R.Value, ".")(2), "0000")

Ich kann im Moment nur unter Office 2010 testen,
der Code sollte aber auch unter 2003 laufen.

Könntest du noch mal nen Blick nehmen?
Danke
MfG Charly