Telefonnummern per Doppelklick
wählen
'Die Bezeichnung "adressen" entspricht dem
Tabellenblatt-Name'
Sub Auto_open()
Worksheets("adressen").OnDoubleClick = "Telefon"
End Sub
Sub Telefon()
Dim Pos As Integer
Dim Nr, Vorwahl, Suchzeich, TelNr
On Error GoTo fehlerPrüfen
TelNr = ActiveCell.Value
For Vorwahl = 1 To 7
Suchzeich = Mid(ActiveCell, Vorwahl, 1)
If Suchzeich < "0" Or Suchzeich > "9" Then GoTo
umwandeln
Next Vorwahl
umwandeln:
Nr = ActiveCell
Pos = InStr(1, Nr, Suchzeich, 0)
Mid(Nr, Pos, 1) = ")"
Nr = "+49(" + Nr
ActiveCell.Value = Nr
wählen:
ActiveCell.Select
Selection.Copy
Rückgabewert = Shell("dialer.exe", 1)
warten
Application.SendKeys keys:="^{v}"
warten
Application.SendKeys keys:="%{w}"
warten
ActiveCell.Value = TelNr
Exit Sub
fehlerPrüfen:
If Err = 5 Then MsgBox "Es wurde keine gültige
Zelle(Tel.-Nummer) gewählt!" + Chr$(13) + "Beispiele 0123
4567, 0123/4567, 0123-4567 usw."
End Sub
Sub warten()
wartezeit = TimeSerial(Hour(Now()), Minute(Now()), Second(Now())
+ 1)
Application.Wait wartezeit
End Sub
Arbeitsmappenweite Suche
Sub MappenWeiteSuche()
Dim t As Worksheet, z As Range, SuchW As String, counter As
Integer, ausgabe As String, knopf As Integer
'Zähler null setzen
counter = 0
'Suchbegriff beim Anwender erfragen
SuchW = InputBox("Geben Sie bitte einen Suchbegriff ein.
Groß- oder Kleinschreibung ist dabei unwichtig:", "Eingabe
Suchbegriff", "PC Praxis")
'wurde kein Begriff eingegeben oder "Abbrechen" geklickt, Makro
verlassen
If SuchW = "" Then Exit Sub
'jedes Worksheet (Tabellenblatt) aufrufen
For Each t In Worksheets
'Sheet aktivieren
t.Activate
'z für erstes Auffinden des Suchbegriffes setzen
Set z = t.Cells.Find(SuchW)
'wenn Begriff auf Blatt, dann Adresse merken und Loop
starten
If Not z Is Nothing Then
erste = z.Address
'Schleife: jedes Vorkommen auf Tabellenblatt
Do
z.Activate
counter = counter + 1
'Anwender fragen: Weiter oder abbrechen?
i = MsgBox("Auf diesem Blatt weitersuchen?", vbYesNo +
vbQuestion)
If i = vbNo Then Exit Do
'Nächstes Vorkommen prüfen
Set z = Cells.FindNext(after:=ActiveCell)
Loop Until erste = z.Address
End If
'Nächstes Tabellenblatt aufrufen
Next t
'Mappe durchsucht, Abschlußmeldung vorbereiten und
ausgeben
ausgabe = "Ende der Suche nach " & SuchW & "!" &
Chr(13) & "Der Suchebegriff wurde " & counter & "mal
gefunden!"
If counter = 0 Then knopf = 16 Else knopf = 64
MsgBox prompt:=ausgabe, Buttons:=knopf, Title:="Information"
End Sub
Tabellenblätter alphabetisch
sortieren
Sub TabellenblätterSortieren()
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
For i = 1 To Sheets.Count
For j = 1 To Sheets.Count - 1
If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name)
Then
Sheets(j).Move after:=Sheets(j + 1)
End If
Next j
Next i
End Sub
Zellinhalt als Dateiname
'Speichername ist hier z.B. A1 - kann jederzeit
angepaßt werden
Sub dateiname()
ort = Range("a1")
If Len(ort) = 0 Then
MsgBox ("Ungültiger Dateiname: Die angegebene Zelle darf
nicht leer sein!")
Else
ActiveWorkbook.SaveAs FileName:=ort & ".xls"
End If
End Sub
Systemdatum bei Änderung
'Systemdatum in Zelle A1 übernehmen
Private Sub Worksheet_Change(ByVal ziel As Excel.Range)
Range("a1") = Date
End Sub
|
