|
Hallo,
als erstes sorry ich bin ein Anfänger in VBA und suche nach einer Lösung zu meinem Problem wie unten beschrieben.
Ich möchte 10 stellige Nummern und Nummern Zahlen Mischungen über dieses Addin (Siehe unten) umwandeln in ein bestimmtes Format
1234567890 soll z.B. umgewandelt werden in 1234.567.890 -> das funktioniert aktuell sehr gut.
Allerdings habe ich auf Zahlen wo vorne Buchstaben stehen wie
AA12345678 diese soll dann wie folgt umgewandelt werden AA12.345.678
Hat evtl. jemand eine Idee wie ich das realisieren kann und was ich an meinem Text unten ändern muss?
Danke schön vorab
Sub matnummitpuenkte()
Dim lastrow As Long
Dim lastcolumn As Integer
Dim x As Long
Dim y As Integer
Dim temp As Double
Dim links As String
Dim mitte As String
Dim rechts As String
Dim boolCalcOn As Boolean
Application.ScreenUpdating = False 'Ermöglicht schnellere Leistung
'Prüfung - wenn Application.Calculation = xlCalculationAutomatic oder
'semiAutomatic muss diese Einstellung am Ende der Makro wieder eingestellt werden
If Application.Calculation = xlCalculationAutomatic Then
boolCalcOn = True
Else
boolCalcOn = False
End If
Application.Calculation = xlCalculationManual 'Ermöglicht schnellere Leistung
On Error Resume Next
'Wenn alle Zeilen ausgewählt worden sind
If Selection.Address = Selection.EntireColumn.Address Then
'Durch jede Spalte in der Auswahl suchen
For y = Selection.Column To Selection.Column + Selection.Columns.Count - 1
'Letzter Wert der Spalte finden
If IsEmpty(Cells(Cells.Rows.Count, y)) = False Then
lastrow = Cells.Rows.Count
Else
lastrow = Cells(Cells.Rows.Count, y).End(xlUp).Row
End If
'Durch jede Zelle in der Spalte suchen
For x = 1 To lastrow
'Prüfen ob die Zelle mit einem Nummer anfängt (damit Leere Zellen, Titeln und Text nicht verändert werden)
If Val(Cells(x, y)) = 0 Then GoTo anchor
'Leerzeichen, Streiche und Pünkte entfernen
Cells(x, y).Value = Replace(Cells(x, y).Value, " ", "")
Cells(x, y).Value = Replace(Cells(x, y).Value, ".", "")
Cells(x, y).Value = Replace(Cells(x, y).Value, "-", "")
'Werte umwandeln
temp = Cells(x, y).Value
Cells(x, y).ClearContents
Cells(x, y).NumberFormat = "@"
Cells(x, y) = CStr(temp)
'Text formatieren, damit es zehn-stellig wird
Cells(x, y).Value = Format(Cells(x, y), "0000000000")
'Text aufteilen und Pünkte dazu hinzufügen
links = Left(Cells(x, y), 4)
mitte = Mid(Cells(x, y), 5, 3)
rechts = Right(Cells(x, y), 3)
Cells(x, y).Value = "" & links & "." & mitte & "." & rechts
'Für Zellen die übersprungen werden sollen
anchor:
'Return Loop (normal)
Next x
'Return Loop
x = 1
Next y
ElseIf Selection.Address = Selection.EntireRow.Address Then
'Durche jede Zeile in der Auswahl suchen
For x = Selection.Row To Selection.Row + Selection.Rows.Count - 1
'Letzter Wert in der Zeile finden
If IsEmpty(Cells(Cells.Columns.Count)) = False Then
lastcolumn = Cells.Columns.Count
Else
lastcolumn = Cells(x, Cells.Columns.Count).End(xlToLeft).Column
End If
'Durch jede Zelle in der Zeile suchen
For y = 1 To lastcolumn
'Prüfen ob die Zelle mit einem Nummer anfängt (damit Leere Zellen, Titeln und Text nicht verändert werden)
If Val(Cells(x, y)) = 0 Then GoTo anchor12
'Leerzeichen, Streiche und Pünkte entfernen
Cells(x, y).Value = Replace(Cells(x, y).Value, " ", "")
Cells(x, y).Value = Replace(Cells(x, y).Value, ".", "")
Cells(x, y).Value = Replace(Cells(x, y).Value, "-", "")
'Zellen umwandeln
temp = Cells(x, y).Value
Cells(x, y).ClearContents
Cells(x, y).NumberFormat = "@"
Cells(x, y) = CStr(temp)
'Text formatieren, damit es zehn-stellig wird
Cells(x, y).Value = Format(Cells(x, y), "0000000000")
'Text aufteilen und Pünkte dazu hinzufügen
links = Left(Cells(x, y), 4)
mitte = Mid(Cells(x, y), 5, 3)
rechts = Right(Cells(x, y), 3)
Cells(x, y).Value = "" & links & "." & mitte & "." & rechts
anchor12:
'Return Loop
Next y
'Return Loop
Next x
'Wenn alle Zeilen nicht ausgewählt worden sind
Else
'Durch jede Zelle in der Auswahl suchen
For Each cell In Selection.Cells
'Prüfen ob die Zelle mit einem Nummer anfängt (damit Leere Zellen, Titeln und Text nicht verändert werden)
If Val(cell) = 0 Then GoTo anchor2
'Leerzeichen, Streiche und Pünkte entfernen
cell.Value = Replace(cell.Value, " ", "")
cell.Value = Replace(cell.Value, ".", "")
cell.Value = Replace(cell.Value, "-", "")
'Werte umwandeln
temp = cell.Value
cell.ClearContents
cell.NumberFormat = "@"
cell.Value = CStr(Format(temp, "0000000000"))
'Text formatieren, damit es zehn-stellig wird
cell.Value = Format(cell, "0000000000")
'Text aufteilen und Pünkte dazu hinzufügen
links = Left(cell, 4)
mitte = Mid(cell, 5, 3)
rechts = Right(cell, 3)
cell.Value = "" & links & "." & mitte & "." & rechts
anchor2:
Next cell
End If
Application.ScreenUpdating = True
'Calculation wieder einstellen, falls es vorher automatisch war
If boolCalcOn = True Then
Application.Calculation = xlCalculationAutomatic
End If
End Sub
|