VBA Code für Excel

Excel lässt sich mittels VBA optimieen. Wiederkehrende Aufgaben oder Handgriffe können optimiert und automatisiert werden. Einige dieser Tools und Funktionen haben wir zur Verfügung gestellt.

Alle zur Verfügung gestellten Materialien sind nach bestem Wissen zusammengestellt worden, dennoch können wir für Fehler oder die Funktion keine Verantwortung übernehmen.

Zeile in die Zwischenablage übernehmen

Funktion übernimmt die aktuelle Zeile zur weiteren Verwendung in die Zwischenablage.

Mehr… 
Sub setClippboard()
On Error GoTo ErrorExit
Dim StrCopy As String
Dim objClip As DataObject
Set objClip = New DataObject
If ActiveSheet.Name = "Questions" Then
dimStrCopy = "ID: " & Range("A" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Status: " & Range("B" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Entered: " & Range("C" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Due-Date: " & Range("D" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Question by: " & Range("L" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Responisble: " & Range("M" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
dimStrCopy = dimStrCopy & "Question" & Chr$(13) & Range("I" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
If Len(Range("J" & ActiveCell.Row).Value) > 0 Then
dimStrCopy = dimStrCopy & "Answer" & Chr$(13) & Range("J" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
End If
If Len(Range("K" & ActiveCell.Row).Value) > 0 Then
dimStrCopy = dimStrCopy & "History" & Chr$(13) & Range("K" & ActiveCell.Row).Value & Chr$(13)
End If
objClip.SetText dimStrCopy
objClip.PutInClipboard
End If
If ActiveSheet.Name = "Issues" Then
dimStrCopy = "ID: " & Range("A" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Status: " & Range("C" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Impact: " & Range("F" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Entered: " & Range("I" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Due-Date: " & Range("J" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Raised by: " & Range("G" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Responisble: " & Range("H" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
dimStrCopy = dimStrCopy & "Issue" & Chr$(13) & Range("B" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
If Len(Range("E" & ActiveCell.Row).Value) > 0 Then
dimStrCopy = dimStrCopy & "History" & Chr$(13) & Range("E" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
End If
objClip.SetText dimStrCopy
objClip.PutInClipboard
End If
Exit Sub
ErrorExit:
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next
End Sub
Weniger…

Arbeitsblatt kopieren

Mit der Funktion wird eine Kopie eines Arbeitsblatts angelegt. Hierbei werden die Kopien benannt und automatisch hochgezählt.

Mehr… 
Sub FormularAnlegen()
On Error Resume Next
Dim KorrFaktor As Integer
Dim ReiterName As String

' Korrekturfaktor, damit die neuen Reiter fortlaufend nummeriert werden
KorrFaktor = 4

' Bezeichnung  der neu anzulegenden Reiter
ReiterName = "Erhebung "

Sheets("Vorlage").Select
Sheets("Vorlage").Copy Before:=Sheets(2)
Sheets("Vorlage (2)").Select
Sheets("Vorlage (2)").Name = ReiterName & Str(LTrim
(ThisWorkbook.Sheets.Count - KorrFaktor))

Exit Sub

ErrorExit:
  MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) &
")"
  Resume Next

End Sub
Weniger…

Datei sichern (Snapshot)

Die Funktion legt eine Sicherungskopie in einem untergeordneten Verzeichnis an. Hierbei wird diese Kopie mit einem Zeitstempel versehen.

Mehr… 
Sub Snapshot2Archive()
' Routine im Excel-Dokument speichern und via Button oder über die Toolbar
verfügbar machen
' Die Excel-Datei muss hierfür Makros unterstützen (*.XLSM)
On Error GoTo ErrorExit
Dim activePath As String
Dim activeName As String
Dim activeFile As String
Dim activeTarget As String
Dim activeTimeStamp As String
Dim activeArchiv As String

ActiveWorkbook.Save
' Sub-Verzeichnis zur Sicherung der Snapshots festlegen
activeArchiv = "_Archiv"
activeTimeStamp = Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss") &
"_"
activePath = ActiveWorkbook.Path
activeName = ActiveWorkbook.Name
activeFile = activePath & "\" & activeName
activeTarget = activePath & "\" & activeArchiv & "\" & activeTimeStamp &
activeName
ChDir (activePath & "\" & activeArchiv & "\")
ActiveWorkbook.SaveCopyAs activeTarget

MsgBox "Das Dokument " & activeTimeStamp & activeName & " wurde im
Verzeichnis " & activeArchiv & " gesichert!", vbInformation, "Snapshot"

Exit Sub
ErrorExit:
  If Err = 76 Then
    MkDir (activePath & "\" & activeArchiv & "\")
    Resume Next
  Else
    MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) &
")"
    Resume Next
  End If

End Sub
Weniger…

Zellen in Clippboard übernehmen

Funktion übernimmt definierte Felder einer Spalte zur weiteren Verwendung in die Zwischenablage.

Mehr… 
Sub setClippboard()
On Error GoTo ErrorExit
Dim StrCopy As String
Dim objClip As DataObject
Set objClip = New DataObject
If ActiveSheet.Name = "Questions" Then
dimStrCopy = "ID: " & Range("A" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Status: " & Range("B" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Entered: " & Range("C" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Due-Date: " & Range("D" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Question by: " & Range("L" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Responisble: " & Range("M" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
dimStrCopy = dimStrCopy & "Question" & Chr$(13) & Range("I" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
If Len(Range("J" & ActiveCell.Row).Value) > 0 Then
dimStrCopy = dimStrCopy & "Answer" & Chr$(13) & Range("J" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
End If
If Len(Range("K" & ActiveCell.Row).Value) > 0 Then
dimStrCopy = dimStrCopy & "History" & Chr$(13) & Range("K" & ActiveCell.Row).Value & Chr$(13)
End If
objClip.SetText dimStrCopy
objClip.PutInClipboard
End If
If ActiveSheet.Name = "Issues" Then
dimStrCopy = "ID: " & Range("A" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Status: " & Range("C" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Impact: " & Range("F" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Entered: " & Range("I" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Due-Date: " & Range("J" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Raised by: " & Range("G" & ActiveCell.Row).Value & Chr$(13)
dimStrCopy = dimStrCopy & "Responisble: " & Range("H" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
dimStrCopy = dimStrCopy & "Issue" & Chr$(13) & Range("B" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
If Len(Range("E" & ActiveCell.Row).Value) > 0 Then
dimStrCopy = dimStrCopy & "History" & Chr$(13) & Range("E" & ActiveCell.Row).Value & Chr$(13) & Chr$(13)
End If
objClip.SetText dimStrCopy
objClip.PutInClipboard
End If
Exit Sub
ErrorExit:
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next
End Sub
Weniger…

Spalten ein- und ausblenden

Die Funktion blendet die definierten Spalten aus, oder wieder ein.

Mehr… 
Sub ShowColumnsNo()
On Error GoTo ErrorExit
'Bereich festlegen
Columns("K:L").Select
Selection.ColumnWidth = 0
Exit Sub
ErrorExit:
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
End Sub
Sub ShowColumnsYes()
On Error GoTo ErrorExit
' Bereich festlegen
Columns("K:L").Select
' Weite der Spalten definieren
Selection.ColumnWidth = 10
Exit Sub
ErrorExit:
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
End Sub
Weniger…

Zelle in einer Maske editieren

Programm liest die aktuelle Zelle aus und stellt sie zur einfacheren  Bearbeitung in Maske dar.

Mehr… 
FRM und FRX Module für den Import in Excel (ZIP File) 
Sub txtShowField()
On Error GoTo ErrorExit
' GUI zur Feldbearbeitung aufrufen
' Aufruf / Makro via Button im Sheet verfügbar machen
frmEditTxt.show
Exit Sub
ErrorExit:
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next
End Sub
Weniger…

Kommentar in einer Maske editieren

Das Programm liest den Kommentar einer Zelle aus uns ermöglicht die Bearbeitung in einer eigenständigen Maske.

Mehr… 
Download FRX und FRM Modul (ZIP File)
Sub txtShowComment()
' GUI zur Bearbeitung von Kommentaren aufrufen
On Error GoTo ErrorExit
frmEditComment.show
Exit Sub
ErrorExit:
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next
End Sub
Weniger…

Zwei Excel-Dateien vergleichen

Die Funktion vergleicht zwei Excel Dateien auf grobe Unterschiede.

Mehr… 
Sub compareExcelWorkbooks()
On Error GoTo ErrorExit
' Programm vergleicht zwei geöffnete Excel-Dateien
Dim tmpWorkSheet As Integer
Dim tmpExit As Boolean

tmpExit = False

If Workbooks.Count > 2 Then
  MsgBox "Es dürfen nur die beiden zu vergleichenden Exceldateien geöffnet sein!", vbInformation, "Hinweis"
  If tmpExit = True Then Exit Sub
End If

If Workbooks.Count < 2 Then
  MsgBox "Es ist nur Exceldateien geöffnet, bitte zweite zu vergleichende Datei öffnen!", vbInformation, "Hinweis"
  If tmpExit = True Then Exit Sub
End If

'Vergleich Anzahl der Tabellenblätter
If Workbooks(1).Worksheets.Count <> Workbooks(2).Worksheets.Count Then
  MsgBox "Die Anzahl der Tabellenblätter ist unterschiedlich!", vbInformation, "Hinweis"
  If tmpExit = True Then Exit Sub
End If

'Vergleich der benutzen Spalten
For tmpWorkSheet = 1 To Workbooks(1).Worksheets.Count
  If Workbooks(1).Worksheets(tmpWorkSheet).UsedRange.Columns.Count <> Workbooks(2).Worksheets(tmpWorkSheet).UsedRange.Columns.Count Then
    MsgBox "Die Anzahl der benutzen Spalten in Blatt " & Workbooks(1).Worksheets(tmpWorkSheet).Name & " ist unterschiedlich!", vbInformation, "Hinweis"
    If tmpExit = True Then Exit Sub
  End If
Next

'Vergleich der benutzen Zeilen
For tmpWorkSheet = 1 To Workbooks(1).Worksheets.Count
  If Workbooks(1).Worksheets(tmpWorkSheet).UsedRange.Rows.Count <> Workbooks(2).Worksheets(tmpWorkSheet).UsedRange.Rows.Count Then
    MsgBox "Die Anzahl der benutzen Zeilen in Blatt " & Workbooks(1).Worksheets(tmpWorkSheet).Name & " ist unterschiedlich!", vbInformation, "Hinweis"
    If tmpExit = True Then Exit Sub
  End If
Next

'Vergleich der benutzen Zellen
For tmpWorkSheet = 1 To Workbooks(1).Worksheets.Count
  If Workbooks(1).Worksheets(tmpWorkSheet).UsedRange.Cells.Count <> Workbooks(2).Worksheets(tmpWorkSheet).UsedRange.Cells.Count Then
    MsgBox "Die Anzahl der benutzen Zellen in Blatt " & Workbooks(1).Worksheets(tmpWorkSheet).Name & " ist unterschiedlich!", vbInformation, "Hinweis"
    If tmpExit = True Then Exit Sub
  End If
Next

Exit Sub

ErrorExit:
  MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
  Resume Next

End Sub

Weniger…

Datum im Bereich nach Wochentag formatieren

Die Funktion formatiert Datumsfelder in einem definierten Bereich. Die Formatierung erfolgt aus Basis der einzelnen Tage (Mo...SO).

Mehr… 
Sub setDateColor()
On Error GoTo ErrorExit
' RGB (n, n, n)
' rot (255, 0, 0)
' weiß (255, 255, 255)
' SW (0, 0, 0)
' hell-grau (217, 217, 217)
' grau (128, 128, 128)

Dim tmpStartZeile As Integer
Dim tmpStartSpalte As Integer
Dim tmpEndeZeile As Integer
Dim tmpEndeSpalte As Integer

tmpStartZeile = 4
tmpStartSpalte = 1
tmpEndeZeile = 50
tmpEndeSpalte = 2

For Each cell In Range(Cells(tmpStartZeile, tmpStartSpalte), Cells(tmpEndeZeile, tmpEndeSpalte))
  If IsDate(cell.Value) Then
    Select Case Weekday(cell.Value)
      Case 1 ' Sonntag
        Range(cell.Address).Font.Bold = True
        Range(cell.Address).Font.Color = RGB(255, 0, 0)
        Range(cell.Address).Interior.Color = RGB(217, 217, 217)
     
       Case 2 ' Montag
         Range(cell.Address).Font.Bold = False
         Range(cell.Address).Font.Color = RGB(0, 0, 0)
         Range(cell.Address).Interior.Color = RGB(255, 255, 255)
        
       Case 3 ' Dienstag
         Range(cell.Address).Font.Bold = False
         Range(cell.Address).Font.Color = RGB(0, 0, 0)
         Range(cell.Address).Interior.Color = RGB(255, 255, 255)
       
      Case 4 ' Mittwoch
         Range(cell.Address).Font.Bold = False
         Range(cell.Address).Font.Color = RGB(0, 0, 0)
         Range(cell.Address).Interior.Color = RGB(255, 255, 255)
    
      Case 5 ' Donnerstag
         Range(cell.Address).Font.Bold = False
         Range(cell.Address).Font.Color = RGB(0, 0, 0)
         Range(cell.Address).Interior.Color = RGB(255, 255, 255)
    
      Case 6 ' Freitag
         Range(cell.Address).Font.Bold = False
         Range(cell.Address).Font.Color = RGB(0, 0, 0)
         Range(cell.Address).Interior.Color = RGB(255, 255, 255)
      
      Case 7 ' Samstag
         Range(cell.Address).Font.Bold = False
         Range(cell.Address).Font.Color = RGB(255, 0, 0)
         Range(cell.Address).Interior.Color = RGB(217, 217, 217)
    End Select
  End If
Next cell

Exit Sub

ErrorExit:
  MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
  Resume Next

End Sub
Weniger…

Zelle formatieren

Funktion formatiert eine Zelle, die einen bestimmten Wert enthält. Die Formatierung erfolgt in einem zuvor festgelegten Bereich.

Mehr… 
Sub setValueColor()
On Error GoTo ErrorExit
' RGB (n, n, n)
' rot (255, 0, 0)
' weiß (255, 255, 255)
' SW (0, 0, 0)
' hell-grau (217, 217, 217)
' grau (128, 128, 128)

Dim tmpStartZeile As Integer
Dim tmpStartSpalte As Integer
Dim tmpEndeZeile As Integer
Dim tmpEndeSpalte As Integer
Dim tmpValue As String

' Bereich festlegen
tmpStartZeile = 4
tmpStartSpalte = 1
tmpEndeZeile = 50
tmpEndeSpalte = 2

' Suchwert festlegen
tmpValue = "SA"

For Each cell In Range(Cells(tmpStartZeile, tmpStartSpalte), Cells(tmpEndeZeile, tmpEndeSpalte))
  If InStr(1, cell.Value, tmpValue) > 0 Then
    Range(cell.Address).Font.Bold = True
    Range(cell.Address).Font.Color = RGB(255, 255, 255)
    Range(cell.Address).Interior.Color = RGB(217, 217, 217)
  End If
Next cell

Exit Sub

ErrorExit:
  MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
  Resume Next

End Sub

Weniger…