das format ist falsch
11.09.2006 14:14:35
rokett
ich bitte um hilfe
das folgende macro ist FAST i.O.
Die Telefonnummern die gespeichert werden sollen stehen
+495309980001 oder +322267787843 in der Tabelle
gespeichert wird aber 4,95308E+11 oder 32999999999
ich brauche aber das pluszeichen und die ganze zahl
gruss
rolf
Option Explicit
Public
Sub TELEFONBUCH_ERSTELLEN()
Dim wbkTELEFONBUCH As Workbook
Dim wksTELEFONBUCH As Worksheet
Dim lngRow As Long, lngRowscounter As Long
Dim intIndex As Integer
Dim blnFound As Boolean
On Error GoTo err_exit
Application.ScreenUpdating = False
For Each wbkTELEFONBUCH In Application.Workbooks
If UCase$(wbkTELEFONBUCH.Name) = "TELEFONBUCH.XLS" Then
blnFound = True
Exit For
End If
Next
If Not blnFound Then _
Set wbkTELEFONBUCH = Workbooks.Open(ThisWorkbook.Path & "\TELEFONBUCH.XLS")
Set wksTELEFONBUCH = wbkTELEFONBUCH.Worksheets("Tabelle1")
wksTELEFONBUCH.Cells.Clear
lngRowscounter = 1
With wksTELEFONBUCH
For lngRow = 2 To T01.Cells(T01.Rows.Count, 3).End(xlUp).Row
.Range(.Cells(lngRowscounter, 1), .Cells(lngRowscounter + 3, 1)).Value = _
T01.Cells(lngRow, 1).Value ' lngRow, 1 = SPALTE A = NAME
.Cells(lngRowscounter, 2).Value = T01.Cells(lngRow, 4).Value
.Cells(lngRowscounter, 3).Value = "P" ' lngRow, 4 = SPALTE TEL PRIVAT
.Cells(lngRowscounter + 1, 2).Value = T01.Cells(lngRow, 5).Value
.Cells(lngRowscounter + 1, 3).Value = "H" ' lngRow, 5 = SPALTE HANDY PRIVAT
.Cells(lngRowscounter + 2, 2).Value = T01.Cells(lngRow, 18).Value
.Cells(lngRowscounter + 2, 3).Value = "D" ' lngRow, 18 = SPALTE TEL DIENST
.Cells(lngRowscounter + 3, 2).Value = T01.Cells(lngRow, 19).Value
.Cells(lngRowscounter + 3, 3).Value = "HD" ' lngRow, 19 = SPALTE HANDY DIENST
lngRowscounter = lngRowscounter + 4
Next
With .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3))
With .Font
.Bold = True
.Size = 13
End With
For intIndex = 7 To 12
With .Borders(intIndex)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Next
End With
.Columns.AutoFit
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = False
ChDir "D:\DATEN\01-EXCEL\01. ADRESSEN"
ActiveWorkbook.SaveAs Filename:="D:\DATEN\01-EXCEL\01. ADRESSEN\TELEFONBUCH.XLS", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Exit Sub
err_exit:
MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehlermeldung"
End Sub