Telefonnummer automatisch per VBA formatieren

Private Sub Worksheet_Change(ByVal Target As Range) 'Für Spalte "B3:B4" If Not Intersect(Target, Range("AC6")) Is Nothing Then Application.EnableEvents = False Target = UCase(Target) Application.EnableEvents = True End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim numb As String If Target = "" Then Exit Sub Application.EnableEvents = False numb = Replace(Target.Value, "+", "") If Len(numb) 13 Then MsgBox "Eingabe zu lang" Else Target.NumberFormat = "+00 000 0000 0000" End If Application.EnableEvents = True End Sub

Hallo Lilli,
ich vermute, dass du die Funktion der bisherigen Worksheet_Change-Prozedur beibehalten willst und dass die Telefonnummern in Spalte B stehen sollen (sonst einfach nur "B" gegen den entsprechenden Buchstaben austauschen).

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rest As String
Dim zf As String
If Not Intersect(Target, Me.Columns("B")) Is Nothing Then
Application.EnableEvents = False
If Target.Cells.Count = 1 Then
If IsNumeric(Target) Then
If Len(Target) > 5 Then
rest = Right$(Target, Len(Target) - 5)
zf = ""
Do Until rest = ""
If Len(rest) > 4 Then
zf = zf & " " & Left$(rest, 4)
rest = Right$(rest, Len(rest) - 4)
Else
zf = zf & " " & rest
rest = ""
End If
Loop
Target = "+" & Left$(Target, 2) & " " & Mid$(Target, 3, 3) & " " & zf
ElseIf Len(Target) > 2 Then
Target = "+" & Left$(Target, 2) & " " & Right$(Target, Len(Target) - 2)
Else
Target = "'+" & Target
End If
End If
End If
Application.EnableEvents = True
Exit Sub
End If
If Not Intersect(Target, Range("AC6")) Is Nothing Then
Application.EnableEvents = False
Target = UCase(Target)
Application.EnableEvents = True
End If
End Sub

https://www.herber.de/bbs/user/132216.xlsm
Viele Grüße
Dieter

Private Sub Worksheet_Change(ByVal Target As Range) Dim rest As String Dim zf As String If Target.Address(False, False) = "AC6" Then Application.EnableEvents = False If Target.Cells.Count = 1 Then If IsNumeric(Target) Then If Len(Target) > 5 Then rest = Right$(Target, Len(Target) - 5) zf = "" Do Until rest = "" If Len(rest) > 4 Then zf = zf & " " & Left$(rest, 4) rest = Right$(rest, Len(rest) - 4) Else zf = zf & " " & rest rest = "" End If Loop Target = "+" & Left$(Target, 2) & " " & Mid$(Target, 3, 3) & " " & zf ElseIf Len(Target) > 2 Then Target = "+" & Left$(Target, 2) & " " & Right$(Target, Len(Target) - 2) Else Target = "'+" & Target End If End If End If Application.EnableEvents = True Exit Sub End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim TN As String If Target.Count > 1 Then Exit Sub If Target.Column 2 Then Exit Sub If Target "" Then If IsNumeric(Target) Then TN = "+" & Left(Target, 2) & " " & Mid(Target, 3, 3) & " " & Mid(Target, 6, 4) _ & " " & Mid(Target, 10, 9 ^ 9) Application.EnableEvents = False Target = TN Application.EnableEvents = True End If End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ERREXIT Application.EnableEvents = False If Target.Count = 1 Then Select Case Target.Address(0, 0) Case "AC6" Target = UCase(Target) Case "A6" 'Zelle Telefonnummer; anpassen Target = TELNUM(Target) End Select End If ERREXIT: Application.EnableEvents = True End Sub Function TELNUM(vntNum) Dim l As Integer vntNum = Replace(vntNum, "+", "") l = Len(vntNum) vntNum = Left(vntNum & String(13, "0"), 13) vntNum = Format(--vntNum, "00 000 0000 0000") TELNUM = "+" & Left(vntNum, l + Int(l / 3) + (l > 9)) End Function

Beliebteste Forumthreads (12 Monate)

Telefonnummer automatisch per VBA formatieren

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

20 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Telefonnummer automatisch per VBA formatieren

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

20 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread