Category Archives: VBA

Telefonliste aus Outlook in Excel exportieren

Über Twitter gab es die Anfrage, ob man nicht eine Telefonliste untereinander darstellen könne. Der Standardexport sieht nur den Export eine Kontaktes pro Zeile vor. Leere Felder werden ebenfalls dargestellt.

Anbei der VBA-Code für das Outlook-Makro:

Sub Telefonliste()
On Error Resume Next
 
Const olFolderContacts = 10
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
 
Set colContacts = objNamespace.GetDefaultFolder(olFolderContacts).Items
 
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
Set objWorksheet = objWorkbook.Worksheets(1)
 
objExcel.Cells(1, 1) = "Name"
objExcel.Cells(1, 2) = "Telefonummer"
 
I = 2
 
For Each ObjContact In colContacts
If Not ObjContact.BusinessTelephoneNumber = "" Then
objExcel.Cells(I, 1).Value = ObjContact.FullName
objExcel.Cells(I, 2).Value = ObjContact.BusinessTelephoneNumber
I = I + 1
End If
 
If Not ObjContact.MobileTelephoneNumber = "" Then
objExcel.Cells(I, 1).Value = ObjContact.FullName
objExcel.Cells(I, 2).Value = ObjContact.MobileTelephoneNumber
I = I + 1
End If
 
If Not ObjContact.HomeTelephoneNumber = "" Then
objExcel.Cells(I, 1).Value = ObjContact.FullName
objExcel.Cells(I, 2).Value = ObjContact.HomeTelephoneNumber
I = I + 1
End If
Next
 
Set objRange = objWorksheet.UsedRange
objRange.EntireColumn.Autofit
End Sub

Büronummer, Mobilnummer & private Nummer werden berücksichtigt.

Listen schnell formatieren per Makro in Excel

Häufiger muss ich Auswertung, Listen oder Planungen in Excel lesen. Manche importiere ich auch aus CSV, Text-Dateien oder gar per ODBC-Verbindung. Bei entsprechenden Datenmengen und aufgrund der Übersichtlichkeit formatiere ich mir diese Tabellen gerne. Ich wurde nun gefragt, wie ich dieses entsprechend schnell durchführe und gerne hinterlege ich hier die vba-Zeilen.

Autofilter auf Zeile 1 setzen:

Range("A1").Select
Selection.AutoFilter
Application.ScreenUpdating = True

Zeile 1 fixieren:

    With ActiveWindow
        .FreezePanes = False
        .SplitColumn = 0
        .SplitRow = 1
        .FreezePanes = True
    End With

Zeilen farblich trennen:

Dim z As Integer
    Dim sp As Integer
    Dim s As Integer
 
    sp = Range("IV1").End(xlToLeft).Column + 1
    z = Range("A65536").End(xlUp).Row + 1
 
    With Range("A1", Chr(63 + sp) & 1)
        .Font.Bold = True
        .EntireColumn.AutoFit
        .Interior.ColorIndex = 15
        .Interior.Pattern = xlSolid
    End With
 
    For s = 3 To z - 1 Step 2
    With Range("A" & s, Chr(63 + sp) & s)
     .Interior.ColorIndex = 37
     .Interior.Pattern = xlSolid                                               '
    End With
    Next s

Diese Funktionen nutze ich in einem Makro gemeinsam und entsprechend habe ich mit einem Klick eine schnell formatierte Tabelle.

Umrechnung von Bytes in größere Einheiten

Bei einigen Auswertungen oder Abfragen per Visual Basic oder anderen Skriptsprachen erhält man Datengrößen in Bytes.
Nun werden diese Zahlen zuweilen sehr lang, so dass man diese zur vernünftigen Darstellung umrechnen sollte.
Dabei soll folgende Umrechnungstabelle unterstützen:

  • 1 KiloByte sind 1024 Bytes
  • 1 MegaByte sind 1048576 Bytes
  • 1 GigaByte sind 1073741824 Bytes
  • 1 TerraByte sind 10995116277776 Bytes

Entsprechend mit diesen Angaben können die Werte in die erforderlichen Größeneinheiten umgerechnet werden.

Word-VBA: Rote Schrift per Makro anpassen

Ich habe ein großes Word-Dokument erhalten, welches wichtige Daten in rot gekennzeichnet hat. Da mir für den Ausdruck nur ein Schwarz-Weiß-Drucker zur Verfügung steht, benötige ich ein anderes Unterscheidungsmerkmal.

Als Idee hatte ich nun die roten Zeichen als Unterscheidungsmerkmal in „fett“ und „kursiv“ zu setzen. Da es viele Seiten zu editieren galt, behalf ich mich mit dem folgenden Makro, welches mir die Umsetzung abnahm:

Sub RedChanger
 'Falls das Zeichen die Farbe "Rot" besitzt, folgendes durchführen:
 '- Schrift auf "automatisch" setzen
 '- Schrift auf "fett" setzen
 '- Schrift auf "kursiv" setzen
 
 Dim WordDocument As Word.Document
 Dim longCount As Long
 Set WordDocument = ActiveDocument
 Application.ScreenUpdating = False
 
 For longCount = 1 To WordDocument.Range.Characters.Count
  If WordDocument.Characters(longCount).Font.Color = wdColorRed Then
      WordDocument.Characters(longCount).Font.Color = 0
      WordDocument.Characters(longCount).Font.Bold = True
      WordDocument.Characters(longCount).Font.Italic = True
  End If
  Application.ScreenUpdating = True
 DoEvents
 Next
End Sub

Dieses Skript kann natürlich auch für andere Zwecke erweitert und angepasst werden. Jedes Zeichen wird dabei einzeln analysiert, so dass die Anpassung eines Textes eine gewisse Zeit in Anspruch nimmt.

VBA: LastLogonTimeStamp in Excel-Tabelle

Um eine Auswertung der letzten Anmeldung von Benutzern zu erstellen habe ich das folgende Skript genutzt.

Es können mehrere Anpassungen durchgeführt werden:

– Domäne => dc=domain,dc=local
– Ausschließen von deaktivierten Konten => (!userAccountControl:1.2.840.113556.1.4.803:=2)
– Anpassung der Zeit auf alle Anmeldungen älter 90 Tage => Format(Now() - 90

Das Skript muss einfach nur aus Excel gestartet werden und man erhält eine sehr übersichtliche Liste. Es ist allerdings zu beachten, dass der Wert "LastLogonTimeStamp" ein sychnronisierter Wert ist und nicht unbedingt tagesaktuell.

Option Explicit
Const ADS_UF_ACCOUNTDISABLE = 2
Const ADS_SCOPE_SUBTREE = 2
Const ADS_UF_DONT_EXPIRE_PASSWD = 65536
Const FLD_FULLNAME = 1
Const FLD_SAM_ACCTNAME = 2
Const FLD_CREATEDATE = 3
Const FLD_PWD_LASTCHNG = 4
Const FLD_PWD_DONTEXPIRE = 5
Const FLD_UAC = 6
Const FLD_LASTLOGON = 7
Const FLD_ADSPATH = 8
Const FLD_MAX = 8
Const HEADROW = 1
Const ASCII_OFFSET = 64
Sub AD_QUERY()
Dim objUser, objLogon, objConnection, objCommand, objRecordSet
Dim strPath, strFullName, strSamAccountName
Dim intUAC, intLogonTime
Dim createdate, pwdchanged
Dim Disabled, PWDexpire, intCounter
Dim objsheet As Excel.Worksheet
Dim rngData As Excel.Range
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Properties("ADSI Flag") = 1
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 10000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
'Search AD Global catalog for user objects that are not disabled
objCommand.CommandText = "<GC://dc=domain,dc=local>; (&(objectClass=user)(objectCategory=person));adspath, samAccountName; subtree"
Application.StatusBar = "Executing AD Query. Please wait..."
Set objRecordSet = objCommand.Execute
Application.StatusBar = "Populating Worksheet with data. Please wait..."
Set objsheet = Application.ActiveWorkbook.Worksheets.Add()
objsheet.Name = Format(Date, "dd-mm-yyyy") & " Raw Data"
intCounter = 2 'Initialise worksheet row counter
objsheet.Cells(HEADROW, FLD_FULLNAME).Value = "Full Name"
objsheet.Cells(HEADROW, FLD_SAM_ACCTNAME).Value = "SAM Account name"
objsheet.Cells(HEADROW, FLD_CREATEDATE).Value = "Create Date (UTC)"
objsheet.Cells(HEADROW, FLD_PWD_LASTCHNG).Value = "PWD Last Changed"
objsheet.Cells(HEADROW, FLD_PWD_DONTEXPIRE).Value = "PWD Don't Expire"
objsheet.Cells(HEADROW, FLD_UAC).Value = "UAC"
objsheet.Cells(HEADROW, FLD_LASTLOGON).Value = "LastLogonTimestamp"
objsheet.Cells(HEADROW, FLD_ADSPATH).Value = "ADSPATH"
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
  strPath = objRecordSet.Fields("adspath")
'Change the global catalog path to an ldap path so that we can access
'all the attributes when binding to the object.
  strPath = Replace(strPath, "GC://", "LDAP://")
  Set objUser = GetObject(strPath)
  intUAC = objUser.userAccountControl
  If (intUAC And ADS_UF_DONT_EXPIRE_PASSWD) = 0 Then
    PWDexpire = False
  Else
    PWDexpire = True
  End If
  On Error Resume Next
  Err.Clear
  'Set objLogon = objUser.LastLogonTimestamp
  Set objLogon = objUser.LastLogon
  If Err.Number <> 0 Then
    intLogonTime = 0
    Err.Clear
  Else
    intLogonTime = objLogon.HighPart * (2 ^ 32) + objLogon.LowPart
    intLogonTime = intLogonTime / (60 * 10000000)
    intLogonTime = intLogonTime / 1440
  End If
  strFullName = objUser.FullName
  If Err.Number <> 0 Then
    strFullName = ""
    Err.Clear
  End If
  createdate = objUser.whenCreated
  If Err.Number <> 0 Then
    createdate = ""
    Err.Clear
  End If
  pwdchanged = objUser.passwordLastChanged
  If Err.Number <> 0 Then
    pwdchanged = ""
    Err.Clear
  End If
  On Error GoTo 0
  strSamAccountName = objUser.SamAccountName
  objsheet.Cells(intCounter, FLD_FULLNAME).Value = strFullName
  objsheet.Cells(intCounter, FLD_SAM_ACCTNAME).Value = strSamAccountName
  objsheet.Cells(intCounter, FLD_CREATEDATE).Value = createdate
  objsheet.Cells(intCounter, FLD_PWD_LASTCHNG).Value = pwdchanged
  objsheet.Cells(intCounter, FLD_PWD_DONTEXPIRE).Value = PWDexpire
  objsheet.Cells(intCounter, FLD_UAC).Value = intUAC
  If intLogonTime <> 0 Then
    objsheet.Cells(intCounter, FLD_LASTLOGON).Value = intLogonTime + #1/1/1601#
  Else
    objsheet.Cells(intCounter, FLD_LASTLOGON).Value = "#1/1/1601#"
  End If
  objsheet.Cells(intCounter, FLD_ADSPATH).Value = strPath
  objRecordSet.MoveNext
  intCounter = intCounter + 1
Loop
Set rngData = objsheet.Range("A1:" & Chr(ASCII_OFFSET + FLD_MAX) & intCounter - 1)
'if the named range already exists we need to delete is before we create it again.
'This will allow more than one audit set to be retained in the same workbook.
On Error Resume Next
ActiveWorkbook.Names("AD_DATA_SET").Delete
On Error GoTo 0
rngData.Name = "AD_DATA_SET"
rngData.Columns.AutoFit
Application.StatusBar = "Ready"
End Sub
 
Sub filter_lastlogon()
Dim rngData As Excel.Range
Set rngData = Range("AD_DATA_SET")
rngData.Worksheet.AutoFilterMode = False
'Filter function seems to ignore locale info so dates must be in US format
rngData.AutoFilter Field:=FLD_LASTLOGON, Criteria1:="=#1/1/1601#", Operator:=xlOr, _
  Criteria2:="<" & Format(Now() - 90, "mm/dd/yyyy")
End Sub
 
Sub filter_pwd_dontexpire()
Dim rngData As Excel.Range
Set rngData = Range("AD_DATA_SET")
rngData.Worksheet.AutoFilterMode = False
rngData.AutoFilter Field:=FLD_PWD_DONTEXPIRE, Criteria1:="=True"
End Sub
 
Sub RemoveFilter()
Dim rngData As Excel.Range
Set rngData = Range("AD_DATA_SET")
rngData.Worksheet.AutoFilterMode = False
End Sub
 
Sub CopyPW()
'Copies the filtered data to a new Worksheet
'Code modified from http://www.contextures.com/xlautofilter03.html#Copy
'Viewed 7/6/2007
Dim rngData As Excel.Range
Dim rng As Range
Dim rng2 As Range
Dim objsheet As Worksheet
Set rngData = Range("AD_DATA_SET")
Call filter_pwd_dontexpire
If Not rngData.Worksheet.FilterMode Then
  MsgBox "Filter Data before selecting this option", vbExclamation
  Exit Sub
End If
With rngData.Worksheet.AutoFilter.Range
  On Error Resume Next
  Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
    .SpecialCells(xlCellTypeVisible)
  On Error GoTo 0
End With
If rng2 Is Nothing Then
    MsgBox "No data to copy"
Else
  Set objsheet = Application.ActiveWorkbook.Worksheets.Add()
  objsheet.Name = Format(Date, "dd-mm-yyyy") & " Password dont expire"
  Set rng = rngData.Worksheet.AutoFilter.Range
  rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _
    Destination:=objsheet.Range("A2")
  objsheet.Cells(HEADROW, FLD_FULLNAME).Value = "Full Name"
  objsheet.Cells(HEADROW, FLD_SAM_ACCTNAME).Value = "SAM Account name"
  objsheet.Cells(HEADROW, FLD_CREATEDATE).Value = "Create Date (UTC)"
  objsheet.Cells(HEADROW, FLD_PWD_LASTCHNG).Value = "PWD Last Changed"
  objsheet.Cells(HEADROW, FLD_PWD_DONTEXPIRE).Value = "PWD Don't Expire"
  objsheet.Cells(HEADROW, FLD_UAC).Value = "UAC"
  objsheet.Cells(HEADROW, FLD_LASTLOGON).Value = "LastLogonTimestamp"
  objsheet.Cells(HEADROW, FLD_ADSPATH).Value = "ADSPATH"
  objsheet.Columns.AutoFit
End If
End Sub
 
Sub CopyLstLogon()
'Copies the filtered data to a new Worksheet
'Code modified from http://www.contextures.com/xlautofilter03.html#Copy
'Viewed 7/6/2007
Dim rngData As Excel.Range
Dim rng As Range
Dim rng2 As Range
Dim objsheet As Worksheet
Set rngData = Range("AD_DATA_SET")
Call filter_lastlogon
If Not rngData.Worksheet.FilterMode Then
  MsgBox "Filter Data before selecting this option", vbExclamation
  Exit Sub
End If
With rngData.Worksheet.AutoFilter.Range
  On Error Resume Next
  Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
    .SpecialCells(xlCellTypeVisible)
  On Error GoTo 0
End With
If rng2 Is Nothing Then
  MsgBox "No data to copy"
Else
  Set objsheet = Application.ActiveWorkbook.Worksheets.Add()
  objsheet.Name = Format(Date, "dd-mm-yyyy") & " LastLogon > 90 days"
  Set rng = rngData.Worksheet.AutoFilter.Range
  rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _
    Destination:=objsheet.Range("A2")
  objsheet.Cells(HEADROW, FLD_FULLNAME).Value = "Full Name"
  objsheet.Cells(HEADROW, FLD_SAM_ACCTNAME).Value = "SAM Account name"
  objsheet.Cells(HEADROW, FLD_CREATEDATE).Value = "Create Date (UTC)"
  objsheet.Cells(HEADROW, FLD_PWD_LASTCHNG).Value = "PWD Last Changed"
  objsheet.Cells(HEADROW, FLD_PWD_DONTEXPIRE).Value = "PWD Don't Expire"
  objsheet.Cells(HEADROW, FLD_UAC).Value = "UAC"
  objsheet.Cells(HEADROW, FLD_LASTLOGON).Value = "LastLogonTimestamp"
  objsheet.Cells(HEADROW, FLD_ADSPATH).Value = "ADSPATH"
  objsheet.Columns.AutoFit
End If
End Sub

Als Gundlage wurde das Skript von der folgenden Seite eingesetzt:
Link

VBA: Mail-Adressen vor Versand durch Abfrage hinzufügen

Ich schreibe häufig e_Mails, bei denen Personen auf CC hinzufgefügt werden sollen. Diese sind bei mir im Regelfall 4 Personen.

Da man im Eifer des Gefechts an der E-Mail-Front diese mal vergessen kann, habe ich mir ein Makro gebaut, welches mich beim Versand einer E-Mail fragt, ob die Mailadressen der Personen im CC-Feld hinzugefügt werden sollen.

Hier das Skript:

Private Sub Application_ItemSend (ByVal Item As Object, cancel as Boolean)
 
If MsgBox("Person 1?", vbYesNo + vbQuestion) = vbYes Then
    Set objMe = Item.Recipients.Add("Person1@mail.de")
        objMe.Type = olCC
   End If
 
If MsgBox("Person 2?", vbYesNo + vbQuestion) = vbYes Then
    Set objMe = Item.Recipients.Add("Person2@mail.de")
        objMe.Type = olCC
   End If
 
If MsgBox("Person 3?", vbYesNo + vbQuestion) = vbYes Then
    Set objMe = Item.Recipients.Add("Person3@mail.de")
        objMe.Type = olCC
   End If
 
   If Not objMe = "" Then
           objMe.Resolve
    Set objMe = Nothing
   End If
End Sub

Wenn man nun eine Mail absenden will, wird man automatisch mit Message-Boxen gefragt, ob man Person 1-3 dem Feld hinzufügen möchte.

Passwortlisten-Erstellung per VBA unter Excel

Zur Erstellung von Passwörtern unter Excel habe ich am gestrigen Abend ein VBA-Skript erstellt, bei den man die Anzahl der Passwörter sowie auch die Anzahl der Zeichen bei jedem Aufruf definieren kann. Desweiteren können die zu nutzenden Ieichen beim Passwort ebenfalls editiert werden.

Sub PasswortErstellung()
 
  Dim myArray As Variant
  myArray = Array("", 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, "A", "B", _
            "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
            "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
            "a", "b", _
            "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", _
            "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", _
            ":", "-", "_", "!", "§", "$", "%", "&amp;", "/", "(", _
            ")", "=", "?", "#", "+")
 
  Dim VarAnzahl2 As Integer
  VarAnzahl2 = UBound(myArray)
 
  Dim VarAnzahl As Variant
  VarAnzahl = Application.InputBox("Anzahl der zu generierenden Passwörter:", "Passwort-Erstellung", 10, , , , , 1)
 
  Dim VarLaenge As Variant
  VarLaenge = Application.InputBox("Wieviele Zeichen soll das Passwort haben?", "Passwort-Erstellung", 8, , , , , 1)
 
  Dim VarColumn As Integer
  Dim VarPassword As Integer
  Dim VarRow As Integer
  Dim StrgPassword As String
 
  If Not TypeName(VarAnzahl) = "Boolean" Then
    Randomize
    VarColumn = ActiveCell.Column
    VarRow = ActiveCell.Row
    For VarRow = VarRow To VarRow + VarAnzahl
      For VarPassword = 1 To VarLaenge
        StrgPassword = StrgPassword &amp; myArray(Int(VarAnzahl2 * Rnd + 1))
      Next VarPassword
      If Application.WorksheetFunction.CountIf(ActiveCell.EntireColumn, StrgPassword) = 0 Then
        ActiveSheet.Cells(VarRow, VarColumn).Value = StrgPassword
      End If
      StrgPassword = ""
    Next VarRow
  End If
End Sub

Die Passwörter werden ab der Zeile geschrieben, die als aktiv makiert ist.