VBA-Makros für Excel (Teil II)

VBA-Makros für Excel (Teil II) - Sammlung diverser Makros
Blattschutz durch Makro Sub SchutzAusEin()
aus- und einschalten ActiveSheet.Unprotect "Test"
MsgBox "Blattschutz ist aufgehoben!"
ActiveSheet.Protect "Test"
MsgBox "Blattschutz ist gesetzt!"
  End Sub  
Tastatureingaben Sub Auto_Open()
abfangen Application.OnKey "%{F8}", "TueDiesUndDas"
End Sub
Sub TueDiesUndDas()
MsgBox ActiveCell.Address
  End Sub  
Excel-Version auslesen Function fGetExcelVer() As Integer
If Application.Version Like "*5*" Then
fGetExcelVer = 5
ElseIf Application.Version Like "*7*" Then
fGetExcelVer = 7
Else
fGetExcelVer = 8
End If
End Function
Sub PerVersion()
MsgBox Application.Version
Select Case Left(Application.Version, 1)
Case "5"
MsgBox "Sie verwenden Excel 5"
Case "7"
MsgBox "Sie verwenden Excel 7/95"
Case "8"
MsgBox "Sie verwenden Excel 8/97"
Case Else
MsgBox "Sie verwenden eine unbekannte Excel-Version"
End Select
ThisWorkbook.Activate
  End Sub  
Kalenderwoche berechnen Function DKW(dat As Date) As Integer
Dim a As Integer
a = Int((dat - DateSerial(Year(dat), 1, 1) + ((WeekDay(DateSerial(Year(dat), 1, 1)) + 1) Mod 7) - 3) / 7) + 1
If a = 0 Then
a = DKW(DateSerial(Year(dat) - 1, 12, 31))
ElseIf a = 53 And (WeekDay(DateSerial(Year(dat), 12, 31)) - 1) Mod 7 <= 3 Then
a = 1
End If
DKW = a
End Function
Function KWoche(d As Date) As Integer
Dim t&
t = DateSerial(Year(d + (8 - WeekDay(d)) Mod 7 - 3), 1, 1)
KWoche = (d - t - 3 + (WeekDay(t) + 1) Mod 7) \ 7 + 1
  End Function  
Stellenzahl auslesen Function CountDigits(s As String) As Integer
Dim i
For i = 1 To Len(s)
If Mid(s, i, 1) Like "#" Then
CountDigits = CountDigits + 1
End If
Next i
  End Function  
Benutzernamen anzeigen Sub FensterName()
ActiveWindow.Caption = ActiveWindow.Caption & " " _ Username aus Excel
& Application.UserName
MsgBox Environ("USERNAME") Username des Betriebssystems
  End Sub  
Excel-Titelzeile ändern Sub TitelWechseln()
Application.Caption = "Veränderte Titelleiste"
  End Sub  
CSV-Datei schreiben Sub Write_Csv()
F = FreeFile(0)
fname = InputBox("Enter the filename with Path:", "Please Enter Output File Name:")
MsgBox "File Selected is: " & fname
If fname <> False Then
Open fname For Output As #F
Set Rng = ActiveCell.CurrentRegion
Debug.Print Rng.Address
FCol = Rng.Columns(1).Column
LCol = Rng.Columns(Rng.Columns.Count).Column
Frow = Rng.Rows(1).Row
Lrow = Rng.Rows(Rng.Rows.Count).Row
For i = Frow To Lrow
outputLine = ""
For j = FCol To LCol
If j <> LCol Then
outputLine = outputLine & Cells(i, j) & ";" Semikolon als Texttrennzeichen, kann
Else geändert werden
outputLine = outputLine & Cells(i, j)
End If
Next j
Print #F, outputLine
Next i
Close #F
End If
End Sub
Sub schreibeCSV()
F = FreeFile(0)
fname = InputBox("Bitte Pfad und Dateinamen der Zieldatei eingeben (z.B. c:\tmp\text.csv):", _
"Eingabe Pfad und Dateiname")
MsgBox "Der Name der Ausgabedatei lautet: " & fname
fseparator = InputBox("Bitte das Trennzeichen eingeben:", "Eingabe Trennzeichen")
MsgBox "Das gewählte Trennzeichen ist: " & fseparator
If fname <> False Then
Open fname For Output As #F
Set Rng = ActiveCell.CurrentRegion
Debug.Print Rng.Address
FCol = Rng.Columns(1).Column
LCol = Rng.Columns(Rng.Columns.Count).Column
Frow = Rng.Rows(1).Row
Lrow = Rng.Rows(Rng.Rows.Count).Row
For i = Frow To Lrow
outputLine = ""
For j = FCol To LCol
If j <> LCol Then
outputLine = outputLine & Cells(i, j) & fseparator
Else
outputLine = outputLine & Cells(i, j)
End If
Next j
Print #F, outputLine
Next i
Close #F
End If
MsgBox "Vorgang abgeschlossen!"
  End Sub  
Zellen nach Datenimport Dim Cell As Range
aufbereiten Sub DatenUmwandeln()
Dim MyRange As Range
Application.ScreenUpdating = False
Set MyRange = ActiveCell.CurrentRegion.Columns(7)
For Each Cell In MyRange
Cell.Select
Application.SendKeys "{F2}+{ENTER}", True
Next Cell
End Sub
Sub ZellenAufbereiten()
For Each Cell In Selection
Cell.Select
Application.SendKeys "{F2}+{ENTER}", True
Next
  End Sub  
Existenz einer Datei prüfen Function FileExist(Filename As String) As Boolean
On Error GoTo HandleError
FileExist = False
If Len(Filename) > 0 Then FileExist = (Dir(Filename) <> "")
Exit Function
HandleError:
FileExist = False
If (Err = 1005) Then
MsgBox "Error - printer missing"
Resume Next
Else
If (Err = 68) Or (Err = 76) Then
MsgBox "Unit or Path do not exist: " & Filename, vbExclamation
Resume Next
Else
MsgBox "Unexpected error " & Str(Err) & " : " &
Error(Err), vbCritical
End
End If
End If
  End Function  
Datei löschen Sub DelFile()
If Len(Dir("c:\windows\test.txt")) > 0 Then
Kill "c:\windows\test.txt"
MsgBox "Test.txt has been killed"
Else
MsgBox "Test.Txt never existed"
End If
  End Sub  
Daten nach Access Sub TestAdd()
senden Dim db As Database, rs As Recordset
Set db = OpenDatabase("C:\Test.mdb")
Set rs = db.OpenRecordset(Name:="Test", Type:=dbOpenDynaset)
With rs
.AddNew
.Fields("Name").Value = Range("A1")
.Fields("Alter").Value = Range("A2")
.Update
End With
rs.Close
db.Close
Set rs = Nothing
  End Sub  
Mappe mit Dateinamen Sub Auto_Close() 'unter Namen speichern, welcher in Zelle A1 steht
aus Zelle speichern Dim f As String; r As Integer
f = ThisWorkbook.Sheets(1).Cells(1; 1).Value
If f = "" Then
f = Application.GetSaveAsFilename(fileFilter:="Excel Workbook(*.xls), *.xls")
If f = False Then
Exit Sub
End If
End If
r = ThisWorkbook.Sheets(1).Cells(1; 1).Characters.Count
If ThisWorkbook.Sheets(1).Cells(1; 1).Characters(r - 3).Text <> ".xls" Then
f = f & ".xls"
End If
ThisWorkbook.SaveAs Filename:=f
  End Sub  
Datei öffnen - Menü mit Sub DateiAuswahl()
definiertem Pfad starten Dim WB As Workbook, TB As Worksheet
Dim i%, dName, dFilter$
dFilter = "Excel-Dateien(*.xls), *.xls"
ChDrive "d"
ChDir "d:\MeineDatenl"
dName = Application.GetOpenFilename(dFilter)
If dName = False Then Exit Sub
Set WB = Workbooks.Open(dName)
Set TB = WB.Worksheets(1)
For i = 1 To 20
TB.Cells(i, 5) = "Spalte E - Zeile " & i
Next i
  End Sub  
Datum als Dateiname Sub DateAsFilename()
Dim sFileName As String
sFileName = Format(Now, "mmddyy") + ".xls"
ActiveWorkbook.SaveAs sFileName
  End Sub  
Schließen eines Dialog- Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
fensters verhindern If CloseMode <> 1 Then Cancel = 1 Prevent user from closing with the Close
  End Sub Box in the title bar.
Kommentare per Sub KommentarSchrift()
Makro formatieren Dim Cmt As Comment
Set Cmt = ActiveCell.AddComment
Cmt.Text "Mein Kommentar"
With Cmt.Shape.TextFrame.Characters.Font
.Name = "Arial"
.Size = 14
End With
  End Sub  
Zellbereich mit Sub KommentarFestlegen()
Kommentar versehen Dim C As Range
For Each C In Selection
If Not C.Comment Is Nothing Then
C.NoteText "Kommentar!"
End If
Next C
  End Sub  
Größe des Sub Kommentargroesse()
Kommentarfensters Dim Kommentarzelle As Range
automatisch Application.DisplayCommentIndicator = xlCommentAndIndicator
festlegen For Each Kommentarzelle In ActiveSheet.Cells.SpecialCells(1)
Kommentarzelle.Comment.Shape.Select True
Selection.AutoSize = True
'Selection.ShapeRange.Width = 150
'Selection.ShapeRange.Height = 100
Next Application.DisplayCommentIndicator = xlCommentIndicatorOnly
  End Sub  
Makroausführung Sub Pause()
pausieren Application.OnTime Now+TimeValue("00:00:01"), "Warten"
End Sub
Sub Warten()
MsgBox "Die Warterei beginnt beim OK !"
NeueStunde = Hour(Now())
NeueMinute = Minute(Now())
NeueSekunde = Second(Now()) + 10
WarteZeit = TimeSerial(NeueStunde, NeueMinute, NeueSekunde)
Application.Wait WarteZeit
MsgBox "Geschafft! 10 Sekunden sind um."
  End Sub  
Makro durch Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Veränderung einer If Target.Address = "$A$1" Or Target.Address = "$A$3"
Zelle starten Then
If Range("A1").Value < Range("A3").Value Then
Macro1
End If
End If
End Sub
Private Worksheet_Calculate()
If Range("A1").Value < Range("A3").Value Then
Macro1
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Schnittpunkt As Range
Set Schnittpunkt = Application.Intersect(Target, Me.Range("A1:A20"))
If Schnittpunkt Is Nothing Then
Exit Sub
Else
MsgBox "Jetzt sollte das Makro ausgeführt werden"
End If
  End Sub  
Makroausführung Sub Screen()
verbergen Application.ScreenUpdating=False
’Dazwischen läuft das Programm ab...
Application.ScreenUpdating=True
  End Sub  
Makroausführung: Sub Abbruch()
Unterbrechen Application.EnableCancelKey = xlDisabled
verhindern End Sub
Sub Abbruch()
Application.EnableCancelKey = xlErrorHandler
  End Sub  
Makroausführung Application.OnEntry = "MeinMakro" Dieser Code arbeitet global in allen geöffneten
nach jeder Eingabe Application.OnEntry = "" Mappen und Tabellen.
Makro nicht durch Application.DisplayAlerts = False Diese Zeile in der ersten Zeile des Makros
Sicherheitsabfragen
unterbrechen   eintragen.
Makrounterbrechung On Error GoTo EH
abfangen Application.EnableCancelKey = xlErrorHandler
While 1 = 1 'Schleife
X = X 'Schleife
Wend 'Schleife
Exit Sub
EH:
MsgBox "Break Key Hit"
  Application.EnableCancelKey = xlInterrupt  
Makros und Code Sub OpenProzedurAnlegen()
dynamisch erstellen Dim nWB As Workbook
Dim mdlWB As Object
Set nWB = Workbooks.Add
Set mdlWB = nWB.VBProject.VBComponents("DieseArbeitsmappe")
With mdlWB.CodeModule
.InsertLines 3, "Private Sub Workbook_Open()"
.InsertLines 4, " Msgbox ""Bin jetzt da!"""
.InsertLines 5, "End Sub"
End With
End Sub
Sub Loeschen()
With Workbooks("test.xls").VBProject
.VBComponents.Remove .VBComponents("Modul1")
End With
  End Sub  
Untermenüs (in Sub MenuErstellen()
Symbolleiste) durch Dim MB As CommandBar
Makro erstellen Dim Ctrl1 As CommandBarControl
Dim Ctrl2 As CommandBarControl
Dim Ctrl1a As CommandBarControl
Dim Ctrl1b As CommandBarControl
Set MB = CommandBars.Add(Name:="Neues Menü", MenuBar:=True)
Set Ctrl1 = MB.Controls.Add(Type:=msoControlPopup)
Ctrl1.Caption = "Untermenü1"
Set Ctrl2 = MB.Controls.Add(Type:=msoControlPopup)
Ctrl2.Caption = "Untermenü2"
Set Ctrl1a = Ctrl1.Controls.Add(Type:=msoControlPopup)
Ctrl1a.Caption = "Daten"
Set Ctrl1b = Ctrl1.Controls.Add(Type:=msoControlPopup)
Ctrl1b.Caption = "Übertragen"
CommandBars("Neues Menü").Visible = True
  End Sub  
Menü "Symbolleisten" Sub DisableToolbarMenu()
de/aktivieren CommandBars("Toolbar List").Enabled = False
End Sub
Sub DisableToolbarMenu()
CommandBars("Toolbar List").Enabled = True
  End Sub  
Menüs dynamisch Private Sub Workbook_Activate()
ein- und ausblenden MenuBars(xlWorksheet).Menus.Add "&Test Menü"
Set ml = MenuBars(xlWorksheet).Menus("Test Menü")
With ml
.MenuItems.Add Caption:="&Daten erfassen", OnAction:="DatenSpeichern"
.MenuItems.AddMenu Caption:="&Auswertungen"
With .MenuItems("Auswertungen")
.MenuItems.Add Caption:="&Auswertung1", OnAction:=""
.MenuItems.Add Caption:="A&uswertung2", OnAction:=""
End With
End With
End Sub
Private Sub Workbook_Deactivate()
MenuBars(xlWorksheet).Reset
End Sub
Private Sub Workbook_Open()
MenuBars(xlWorksheet).Menus.Add "&Test Menü"
Set ml = MenuBars(xlWorksheet).Menus("Test Menü")
With ml
.MenuItems.Add Caption:="&Daten erfassen", OnAction:="DatenSpeichern"
.MenuItems.AddMenu Caption:="&Auswertungen"
With .MenuItems("Auswertungen")
.MenuItems.Add Caption:="&Auswertung1", OnAction:=""
.MenuItems.Add Caption:="A&uswertung2", OnAction:=""
End With
End With
  End Sub  
Symbolleisten Sub Verstecken()
ausblenden For Each tb in Toolbars
tb.Visible = False
Next tb
  End Sub  
Shortcut-Menü ein- Sub ShortCutOnOff()
und ausschalten Application.ShortcutMenus(xlWorksheetCell).Enabled = False
  End Sub  
Symbolleiste: Sub SymbolGrauen()
Icons deaktivieren CommandBars("Standard").Controls(1).Enabled = False
  End Sub  
Symbolleiste Sub NeueSymbolleiste()
positionieren Dim cmdB As CommandBar
et cmdB = CommandBars.Add("MyToolbar", temporary:=True)
With cmdB
.Left = 50
.Top = 100
.Visible = True
End With
  End Sub  
ID von Symbolleisten ’Drei verschiedene Makros können verwendet werden:
und Symbolen ’CommandBarControlID_List liefert die IDs der Symbolleisten mit Menüpunkt, ID-Nr und Beschreibung
auslesen ’CommandBarFaceID_List liefert alle FaceIDs mit Bild und ID
’CommandBar_List liest die Excel-internen Bezeichnungen der Menüs, Menüpunkte, deren Typ und ID aus
Dim cbb As CommandBarButton, ComBar As CommandBar, cbc As CommandBarControl
Sub CommandBarControlID_List()
Dim a, b, c
Application.ScreenUpdating = False
For Each ComBar In Application.CommandBars
If ComBar.Name = "test" Then ComBar.Delete
Next
Set ComBar = Application.CommandBars.Add(Name:="test",
Position:=msoBarTop)
b = 0
c = 1
For a = 1 To 50000
On Error Resume Next
Set cbb = ComBar.Controls.Add(Id:=a)
If Err.Number <> 0 Then GoTo weiter
cbb.CopyFace
With Workbooks("FaceIDs").Sheets(1)
.Cells((c Mod 100) + 1, (c \ 100) + b + 1).Formula = a
.Cells((c Mod 100) + 1, (c \ 100) + b + 2).Activate
ActiveSheet.Paste
.Cells((c Mod 100) + 1, (c \ 100) + b + 3).Formula = cbb.Caption
End With
If (c + 1) Mod 100 = 0 Then b = b + 3
c = c + 1
weiter:
Application.CommandBars("test").FindControl(Id:=a).Delete
Err.Clear
Next
End Sub
Sub CommandBarFaceID_List()
Dim a, b
Application.ScreenUpdating = False
For Each ComBar In Application.CommandBars
If ComBar.Name = "test" Then ComBar.Delete
Next
On Error Resume Next
Set ComBar = Application.CommandBars.Add(Name:="test",
Position:=msoBarTop)
Set cbb = ComBar.Controls.Add(Id:=1)
b = 0
For a = 1 To 3518
With cbb
.FaceId = a
.CopyFace
End With
With ThisWorkbook.Sheets(1)
.Cells((a Mod 100) + 1, (a \ 100) + b + 1).Formula = a
.Cells((a Mod 100) + 1, (a \ 100) + b + 2).Activate
ActiveSheet.Paste
End With
If (a + 1) Mod 100 = 0 Then b = b + 2
Next
End Sub
Sub CommandBar_List()
Application.ScreenUpdating = False
Dim a, b, c, cbc, d
b = 1
d = 0
For Each a In Application.CommandBars
Cells(b + d, 1) = a.Name
Cells(b + d, 2) = "Item-no: " & b
For Each cbc In a.Controls
d = d + 1
Cells(b + d, 3) = cbc.Caption
Cells(b + d, 4) = Cells(cbc.Type, 10)
Cells(b + d, 5) = "Type: " & cbc.Type
Cells(b + d, 6) = "ID: " & cbc.Id
Next
b = b + 1
Next
  End Sub  
Menüeintrag Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, _
neuen Befehl ByVal Target As Excel.Range, Cancel As Boolean)
zuordnen Set chgEinfügen = Application.ShortcutMenus(xlWorksheetCell).MenuItems("Einfügen")
With chgEinfügen
.OnAction = "mkrEinfügen"
End With
End Sub
Sub mkrEinfügen()
Selection.PasteSpecial Paste:=xlValues
  End Sub  
Quickinfo zuordnen Sub QuickInfo()
Application.Toolbars("SybolleistenName").ToolbarButtons(Indexzahl).Name = "Infotext"
  End Sub  
Zahl in Text ändern Function DollarText(vNumber) As Variant
Dim sDollars As String, sCents As String, iLen As Integer, sTemp As String
Dim iPos As Integer, iHundreds As Integer, iTens As Integer, iOnes As Integer
Dim bHit As Boolean, vOnes As Variant, vTeens As Variant, vTens As Variant
Dim sUnits(2 To 5) As String
If Not IsNumeric(vNumber) Then
Exit Function
End If
sDollars = Format(vNumber, "###0.00")
iLen = Len(sDollars) - 3
If iLen > 15 Then
DollarText = CVErr(xlErrNum)
Exit Function
End If
sCents = Right$(sDollars, 2) & "/100 Dollars"
If vNumber < 1 Then
DollarText = sCents
Exit Function
End If
sDollars = Left$(sDollars, iLen)
vOnes = Array("", "One", "Two", "Three",
"Four", "Five", "Six", "Seven", "Eight", "Nine")
vTeens = Array("Ten", "Eleven", "Twelve",
"Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen",
"Eighteen", "Nineteen")
vTens = Array("", "", "Twenty", "Thirty",
"Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety")
sUnits(2) = "Thousand"
sUnits(3) = "Million"
sUnits(4) = "Billion"
sUnits(5) = "Trillion"
sTemp = ""
For iPos = 15 To 3 Step -3
If iLen >= iPos - 2 Then
bHit = False
If iLen >= iPos Then
iHundreds = Asc(Mid$(sDollars, iLen - iPos + 1, 1)) - 48
If iHundreds > 0 Then
sTemp = sTemp & " " & vOnes(iHundreds) & "Hundred"
bHit = True
End If
End If
iTens = 0
iOnes = 0
If iLen >= iPos - 1 Then
iTens = Asc(Mid$(sDollars, iLen - iPos + 2, 1)) - 48
End If
If iLen >= iPos - 2 Then
iOnes = Asc(Mid$(sDollars, iLen - iPos + 3, 1)) - 48
End If
If iTens = 1 Then
sTemp = sTemp & " " & vTeens(iOnes)
bHit = True
Else
If iTens >= 2 Then
sTemp = sTemp & " " & vTens(iTens)
bHit = True
End If
If iOnes > 0 Then
If iTens >= 2 Then
sTemp = sTemp & "-"
Else
sTemp = sTemp & " "
End If
sTemp = sTemp & vOnes(iOnes)
bHit = True
End If
End If
If bHit And iPos > 3 Then
sTemp = sTemp & " " & sUnits(iPos \ 3)
End If
End If
Next iPos
DollarText = Trim(sTemp) & " and " & sCents
  End Function 'DollarText  
Umlaute ersetzen Sub UmlauteWandeln()
Dim MyRange As Range
Dim Cell As Range
Application.ScreenUpdating = False
Set MyRange = Selection
For Each Cell In MyRange
Selection.Replace What:="ß", Replacement:="ss", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="ü", Replacement:="ue", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="Ü", Replacement:="Ue", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="ö", Replacement:="oe", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="Ö", Replacement:="Oe", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="ä", Replacement:="ae", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="Ä", Replacement:="Ae", LookAt:=xlPart, MatchCase:=True
Next Cell
  End Sub  
Groß-/Kleinschreibung Sub ToggleCase()
tauschen Dim Upr, Lwr, Ppr
Set OriginalCell = ActiveCell 'Originaladresse speichern
Set OriginalSelection = Selection
If IsEmpty(ActiveCell) Then GoTo NoneFound
On Error GoTo Limiting
If OriginalCell = OriginalSelection Then
Selection.Select
GoTo Converting
Else
Resume Next
End If
Limiting: 'Auswahl auf gültige Zellen begrenzen
On Error GoTo NoneFound
Selection.SpecialCells(xlCellTypeConstants, 3).Select
Converting:
Application.StatusBar = "Ändere Gross- und Kleinschreibung..." 'Statusbar ändern
For Each DCell In Selection.Cells
Upr = UCase(DCell)
Lwr = LCase(DCell)
If Upr = DCell.Value Then
DCell.Value = Lwr
Else
DCell.Value = Upr
End If
Next DCell
Application.StatusBar = False 'Statusbar zurücksetzen
Exit Sub
NoneFound:
MsgBox "Alle Zellen der aktuelllen Auswahl enthalten Formeln oder sind leer!", vbExclamation, " Fehler aufgetreten"
OriginalSelection.Select
OriginalCell.Activate
  End Sub  
Minuszeichen Sub MinusUmstellen()
umstellen Range("a1").Select
Do Until ActiveCell.Value = ""
altstring = ActiveCell.Value
längealtstring = Len(altstring)
längealtstring = längealtstring - 1
rechteszeichen = Right(altstring, 1)
If rechteszeichen = "-" Then neuerstring = Left(altstring, längealtstring): neuerstring = "-" + neuerstring
ActiveCell.Value = neuerstring
ActiveCell.Offset(1, 0).Range("A1").Select
Loop
End Sub
Sub TrailingNegatives()
For Each Cell In Selection
Cell.Select
altstring = ActiveCell.Value
längealtstring = Len(altstring)
längealtstring2 = längealtstring - 1
rechteszeichen = Right(altstring, 1)
If rechteszeichen = "-" Then neuerstring = Left(altstring, längealtstring2): _
neuerstring = "-" + neuerstring: ActiveCell.Value = neuerstring
Next
  End Sub  
Erste leere Zelle Sub Finde()
in einer Spalte Columns(MyColumnNumber).SpecialCells(xlCellTypeBlanks).Cells(1)
finden End Sub
Sub Finde()
Cells(Application.WorksheetFunction.CountA(Columns(MyColumnNumber)) + 1, _
MyColumnNumber)
  End Sub  
Zellen im Makro Sub Kopieren()
ohne Zwischen- Dim aBereich As Range, bBereich As Range
ablage kopieren Set aBereich = Range("A1:B2")
Set bBereich = Range("F1:G2")
bBereich.Value = aBereich.Value Werte übertragen
bBereich.NumberFormat = aBereich.NumberFormat Zahlenformate übertragen
  End Sub  
Zellen zeilenweise Private Sub Worksheet_Change(ByVal Target As Excel.Range)
ausfüllen If Target.Address = "$A$1" Then
Set actcell = [C1]
Do While actcell <> ""
Set actcell = actcell.Offset(0, 1)
Loop
actcell.Value = Target.Value
End If
  End Sub  
Erste leere Zelle Sub Finde()
finden Selection.SpecialCells(xlBlanks).Areas(1).Cells(1).Select
  End Sub  
Fundstellen in Sub FundstellenSuchen()
Userform auflisten Dim C As Range, Gefunden(), i%
For Each C In Tabelle1.Range("A1").CurrentRegion
If InStr(C, "Zei") > 0 Then
ReDim Preserve Gefunden(i)
Gefunden(i) = C.Address(False, False)
UserForm1.ListBox1.List = Gefunden
i = i + 1
End If
Next C
UserForm1.Show
  End Sub  
Zeilen mit Summe Sub HideRows()
Null ausblenden For Each rngRow In ActiveSheet.UsedRange.Rows
If Application.Sum(rngRow) = 0 Then
rngRow.EntireRow.Hidden = True
End If
Next rngRow
  End Sub  
Zeilen mit Summe Sub DeleteRow()
Null löschen Dim N As Long
For N = Selection(1, 1).Row + Selection.Rows.Count - 1 To Selection(1, 1).Row Step -1
With Cells(N, 1)
If .Value = 0 And Not .HasFormula Then
.EntireRow.Delete
End If
End With
Next N
  End Sub  
Tabellenname Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
automatisch nach If Target.Address = Sh.Range("jobNumber").Address Then
Zellinhalt benennen Sh.Name = szRenameSheet(Sh, Target)
End If
End Sub
Private Function szRenameSheet(ByVal Sh As Worksheet, ByVal Target As Excel.Range) As String
Dim szName As String
If Not IsNull(Target) Then
szName = CStr(Target.Value)
With Application.WorksheetFunction
szName = .Substitute(szName, ":", "")
szName = .Substitute(szName, "/", "")
szName = .Substitute(szName, "\", "")
szName = .Substitute(szName, "?", "")
szName = .Substitute(szName, "*", "")
szName = .Substitute(szName, "[", "")
szName = .Substitute(szName, "]", "")
End With
szRenameSheet = Left$(szName, 31)
End If
  End Function  
Neuberechnung
erzwingen
SendKeys "^%{F9}"  
Formeln zählen Sub Count_Formula()
Dim R As Integer
R = 0
Range(Cells(1, 1), Selection.SpecialCells(xlLastCell)).Select
For Each Cell In Selection
If Left(Cell.Formula, 1) = "=" Then
R = R + 1
End If
Next Cell
Selection.SpecialCells(xlFormulas, 23).Select
MsgBox "Es sind " & R & " Formeln in der Tabelle " & ActiveSheet.Name & "enthalten"
End Sub
Sub CountFormSub()
MsgBox ActiveSheet.UsedRange.SpecialCells(xlFormulas).Count
End Sub
Function countformulas() As Integer
Dim x As Range, y As Integer
Application.Volatile
For Each x In ActiveSheet.UsedRange
If x.HasFormula Then y = y + 1
Next x
countformulas = y
  End Function  
Seitenzahlen in Zelle Sub SeitenNr()
Dim Trennzeile As Variant
Dim AlteZeile As Integer
Dim Trennspalte As Variant
Dim AlteSpalte As Integer
Dim V_Seitenanzahl As Integer
Dim H_Seitenanzahl As Integer
Dim V_Seite As Integer
Dim H_Seite As Integer
V_Seitenanzahl = 0
V_Seite = 0
AlteZeile = 0
AlteSpalte = 0
Do
V_Seitenanzahl = V_Seitenanzahl + 1
Trennzeile = ExecuteExcel4Macro("INDEX(GET.DOCUMENT(64)," &
V_Seitenanzahl & ")")
If IsError(Trennzeile) Then Exit Do
If Trennzeile <= AlteZeile Then Exit Do
AlteZeile = Trennzeile
If Trennzeile >= ActiveCell.Row And V_Seite = 0 Then
V_Seite = V_Seitenanzahl
End If
Loop
V_Seitenanzahl = V_Seitenanzahl - 1
H_Seitenanzahl = 0
H_Seite = 0
Do
H_Seitenanzahl = H_Seitenanzahl + 1
Trennspalte = ExecuteExcel4Macro("INDEX(GET.DOCUMENT(65)," _
& H_Seitenanzahl & ")")
If IsError(Trennspalte) Then Exit Do
If Trennspalte <= AlteSpalte Then Exit Do
AlteSpalte = Trennspalte
If Trennspalte >= ActiveCell.Column And H_Seite = 0 Then
H_Seite = H_Seitenanzahl
End If
Loop
H_Seitenanzahl = H_Seitenanzahl - 1
If ActiveSheet.PageSetup.Order = xlOverThenDown Then
ActiveCell.Formula = "Seite " & (V_Seite - 1) * H_Seitenanzahl +
H_Seite & " von " & H_Seitenanzahl * V_Seitenanzahl
Else
ActiveCell.Formula = "Seite " & (H_Seite - 1) * V_Seitenanzahl +
V_Seite & " von " & H_Seitenanzahl * V_Seitenanzahl
End If
  End Sub  
Arbeitsmappen Sub CompareWorkbooks()
vergleichen Dim iWB As Integer, iWS As Integer
Dim rngObj As Range
If Workbooks(1).Worksheets.Count <> Workbooks(2).Worksheets.Count Then
MsgBox "Number of worksheets differs"
Exit Sub
End If
For iWS = 1 To Workbooks(1).Worksheets.Count
If Workbooks(1).Worksheets(iWS).UsedRange.Cells.Count <> _
Workbooks(2).Worksheets(iWS).UsedRange.Cells.Count Then
MsgBox "Number of used cells in sheet " & iWS & "differs"
Exit Sub
End If
For Each rngObj In Workbooks(1).Worksheets(iWS).UsedRange
If rngObj.Value <> Workbooks(2).Worksheets(iWS).Range(rngObj.Address).Value
Then
For iWB = 1 To 2
Workbooks(iWB).Worksheets(iWS).Activate
ActiveSheet.Range(rngObj.Address).Activate
Next
MsgBox "Difference detected at sheet " & iWS & " at cell " & rngObj.Address(False, False)
Exit For
End If
Next
Next
  End Sub  
Excel - Fenster Sub InTheMiddle()
positionieren Dim dWidth As Double, dHeight As Double
With Application
.WindowState = xlMaximized
dWidth = .Width
dHeight = .Height
.WindowState = xlNormal
.Top = dHeight / 4
.Height = dHeight / 2
.Left = dWidth / 4
.Width = dWidth / 2
End With
  End Sub  
Fußzeilen bei Sub Datum_in_Fusszeile()
doppelseitigem Dim SeitenNummer%, X%, Zaehler As Boolean
Ausdruck Zaehler = True
X = ExecuteExcel4Macro("get.document(50)")
For SeitenNummer = 1 To X
If Zaehler = True Then
With ActiveSheet.PageSetup
.RightFooter = "&D"
.LeftFooter = ""
End With
End If
If Zaehler = False Then
With ActiveSheet.PageSetup
.RightFooter = ""
.LeftFooter = "&D"
End With
End If
ActiveWindow.SelectedSheets.PrintOut From:=SeitenNummer, To:=SeitenNummer, Copies:=1
Zaehler = Not Zaehler
Next SeitenNummer
  End Sub  
Datensätze Sub DatensaetzeLoeschen() Diese Prozedur kann man wie folgt einsetzen:
automatisch Antwort = MsgBox("Alle sichtbaren Zeilen löschen?", _ 1. Filter definieren, so dass in der Liste nur noch
löschen vbYesNo, "Zeilen löschen") Einträge angezeigt werden, die man löschen will.
If Antwort = vbNo Then GoTo Ende
Application.ScreenUpdating = False 2. Auf eine beliebige Zelle in der Liste klicken.
ErsteZeile = ActiveCell.CurrentRegion.Row + 1 3. Das Makro starten.
ErsteSpalte = ActiveCell.CurrentRegion.Column 4. Nachdem man die Abfrage mit JA bestätigt hat
LetzteZeile = ErsteZeile + _ werden die gefundenen Listenzeilen gelöscht.
ActiveCell.CurrentRegion.Rows.Count - 2 5. Mit DATEN-FILTER-ALLE ANZEIGEN den Rest
LetzteSpalte = ErsteSpalte + _ der Liste wieder einblenden.
ActiveCell.CurrentRegion.Columns.Count - 1 Funktionsweise des Makros: Nachdem die Abfrage
Set SichtbarerBereich = Range(Cells(ErsteZeile, _ mit JA beantwortet wurde, ermittelt die Prozedur
ErsteSpalte), Cells(LetzteZeile, _ die erste / letzte Zeile, sowie die erste / letzte Spalte
LetzteSpalte)).SpecialCells(xlVisible) des Datenbereiches. Anschließend werden alle
AnzahlBereiche = SichtbarerBereich.Areas.Count sichtbaren Zellen des Datenbereichs markiert.
For Zaehler = 1 To AnzahlBereiche Da es sich um ein Filterergebnis handelt, werden
Range(SichtbarerBereich.Areas(1).Address). _ zwischen den sichtbaren Zeilen die nicht passenden
Delete Shift:=xlUp Einträge ausgeblendet; die Markierung besteht
Next aus mehreren Bereichen. Die Anzahl der Bereiche
Application.ScreenUpdating = True wird mit "Areas.Count" ermittelt und eine For-
Ende: Next-Schleife löscht jeden Bereich mit "Delete".
  End Sub  
Bedingte Formatierung Private Sub Worksheet_Change(ByVal Target As Excel.Range)
mit mehr als Select Case Target.Value
drei Bedingungen Case 1
Target.Interior.ColorIndex = 1 'Schwarz
Case 2
Target.Interior.ColorIndex = 2 'Weiß
Case 3
Target.Interior.ColorIndex = 3 'Rot
Case 4
Target.Interior.ColorIndex = 4 'Grün
Case 5
Target.Interior.ColorIndex = 5 'Blau
Case 6
Target.Interior.ColorIndex = 6 'Gelb
Case Else
Target.Interior.ColorIndex = xlColorIndexNone
End Select
  End Sub  
Die drei höchsten Man möchte die drei größten Werte aus einem Bereich von 100 Zellen
Werte summieren summieren. Das Problem dabei ist, dass die Werte nicht sortiert sind, so
dass der Einsatz einer einfachen Summenformel ausscheidet.
Die Spitzenwerte eines Tabellenbereichs kann man mit der Funktion
KGROESSTE ermitteln. Die Funktion erwartet als ersten Parameter die
Adresse des zu durchsuchenden Bereichs und als zweiten Parameter
eine Zahl, die angibt, welchen Wert man genau sucht.
Wenn sich die Werte zum Beispiel im Bereich A1:A100 befinden,
liefert folgende Formel den höchsten Wert: =KGROESSTE(A1:A100;1)
Die Summe aus dem "höchsten", dem "zweithöchsten" und dem
dritthöchsten Wert erhält man mit folgender Formel: =KGROESSTE(A1:A100;1)+KGROESSTE(
A1:A100;2)+KGROESSTE(A1:A100;3)
Verkürzen lässt sich der Ausdruck mit einer Arrayformel: =SUMME(KGROESSTE(A1:A100;{1;2;3}))
Zur Eingabe einer Arrayformel schließt man den Ausdruck mit
Strg+Umschalt+Return ab, so dass Excel die Formel automatisch
mit geschweiften Klammern umgibt.
Obwohl diese Schreibweise kompakter ist als die zuvor genannte
mit dem +-Operator, wird die Eingabe mühseliger, je mehr Spitzenwerte
summiert werden sollen. Wenn man etwa die fünf höchsten Werte des
Bereichs addieren will, müsste man {1;2;3;4;5}" als Parameterarray
eingeben.
Flexibler ist folgende Formel (hier für fünf Spitzenwerte): =SUMME(KGROESSTE(A1:A100;ZEILE(
Auch diese Formel muss man per Strg+Umschalt+Return INDIREKT("1:5"))))
als Arrayformel eingeben. Wenn man aber eine andere Summe - z.B. aus den zehn
höchsten Werten - benötigt, muss man den zweiten Wert der INDIREKT-
  Funktion anpassen, indem man statt "5" den Wert "10" einträgt.
Arbeitslohn mit An diesem Beispiel erkennt man, dass das Rechnen mit =ZEITWERT("18:00")-ZEITWERT("12:00")
Arbeitszeit ermitteln Uhrzeiten nur bei ganz simplen Additionen und Subtraktionen wirklich einfach ist.
Um Arbeitslohn auf Grundlage der berechneten Zeit zu ermitteln, ist es
notwendig, Uhrzeiten in eine Dezimalzahl zu verwandeln: =ZEITWERT("6:00")*24
Das Ergebnis ist in diesem Fall "6" und diese Zahl kann man dann mit
einem Stundensatz multiplizieren.
  So wandelt man eine Dezimalzahl in eine Uhrzeit um: die Zahl durch 24 dividieren.
Alle Symbolleisten Sub SymbolleistenReset()
zurücksetzen Dim Leiste As CommandBar
For Each Leiste In CommandBars
If Leiste.Type = msoBarTypeNormal Then
If Leiste.BuiltIn Then Leiste.Reset
End If
Next Leiste
  End Sub  
Sponsoren und Investoren

Sponsoren und Investoren sind jederzeit herzlich willkommen!
Wenn Sie die Information(en) auf dieser Seite interessant fanden, freuen wir uns über eine kleine Spende. Empfehlen Sie uns bitte auch in Ihren Netzwerken (z. B. Twitter, Facebook oder Google+). Herzlichen Dank!

Nach oben Sitemap
Impressum & Kontakt