VBA-Makros für Excel (Teil III)

Sammlung diverser Makros


Show IndexNo (ZOrderPosition) and	Sub Shape_Index_Name()
name of all Shapes on a worksheet	Dim myVar As Shapes
	Dim shp As Shape
	Set myVar = Sheets(1).Shapes
	For Each shp In myVar
	MsgBox "Index = " & shp.ZOrderPosition & vbCrLf & _
	"Name = " & shp.Name
	Next
	End Sub
Create a Word Document, open and	Sub Open_MSWord()	You should create a reference to the
put some text from Excel	On Error GoTo errorHandler	Word Object Library in the VB-Editor.
	Dim wdApp As Word.Application
	Dim myDoc As Word.Document
	Dim mywdRange As Word.Range
	Set wdApp = New Word.Application
	With wdApp
	.Visible = True
	.WindowState = wdWindowStateMaximize
	End With
	Set myDoc = wdApp.Documents.Add
	Set mywdRange = myDoc.Words(1)
	With mywdRange
	.Text = Range("F6") & " This text is being used to test subroutine." & " More meaningful text to follow."
	.Font.Name = "Comic Sans MS"
	.Font.Size = 12
	.Font.ColorIndex = wdGreen
	.Bold = True
	End With
	errorHandler:
	Set wdApp = Nothing
	Set myDoc = Nothing
	Set mywdRange = Nothing
	End Sub
Insert stars into a worksheet and	Sub ShowStars()
then removes them	Randomize
	StarWidth = 25
	StarHeight = 25
	For i = 1 To 10
	TopPos = Rnd() * (ActiveWindow.UsableHeight - StarHeight)
	LeftPos = Rnd() * (ActiveWindow.UsableWidth - StarWidth)
	Set NewStar = ActiveSheet.Shapes.AddShape _
	(msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight)
	NewStar.Fill.ForeColor.SchemeColor = Int(Rnd() * 56)
	Application.Wait Now + TimeValue("00:00:01")
	DoEvents
	Next i
	Application.Wait Now + TimeValue("00:00:02")
	Set myShapes = Worksheets(1).Shapes
	For Each shp In myShapes
	If Left(shp.Name, 9) = "AutoShape" Then
	shp.Delete
	Application.Wait Now + TimeValue("00:00:01")
	End If
	Next
	Worksheets(1).Shapes("Message").Visible = True
	End Sub
Unlock Cells that do NOT contain a	Sub Set_Protection()	This sub looks at every cell on the
formula, a date or text	On Error GoTo errorHandler	worksheet. If the cell doesn't have
	Dim myDoc As Worksheet	a formula, a date or text and the cell
	Dim cel As Range	is numeric, it unlocks the cell.
	Set myDoc = ActiveSheet	The font is blue.
	myDoc.UnProtect	For everything else, it locks the cell
	For Each cel In myDoc.UsedRange	and makes the font black.
	If Not cel.HasFormula And Not _	It then protects the worksheet.
	TypeName(cel.Value) = "Date" And Application.IsNumber(cel) Then
	cel.Locked = False	This has the effect of allowing someone
	cel.Font.ColorIndex = 5	to edit the numbers, but they can't change
	Else	text, dates or formulas.
	cel.Locked = True
	cel.Font.ColorIndex = xlColorIndexAutomatic
	End If
	Next
	myDoc.Protect
	Exit Sub
	errorHandler:
	MsgBox Error
	End Sub
Tests the values in each cell of a	Sub Test_Values()	Tests the value in each cell of a column
range	Dim topCel As Range, bottomCel As Range, _	and if it is greater than a given number,
	sourceRange As Range, targetRange As Range	places it in another column.
	Dim x As Integer, i As Integer, numofRows As Integer	This is just an example so the source
	Set topCel = Range("A2")	range, target range and test value may
	Set bottomCel = Range("A65536").End(xlUp)	be adjusted to fit different requirements.
	If topCel.Row > bottomCel.Row Then End	Test if source range is empty.
	Set sourceRange = Range(topCel, bottomCel)
	Set targetRange = Range("D2")
	numofRows = sourceRange.Rows.Count
	x = 1
	For i = 1 To numofRows
	If Application.IsNumber(sourceRange(i)) Then
	If sourceRange(i) > 1300000 Then
	targetRange(x) = sourceRange(i)
	x = x + 1
	End If
	End If
	Next
	End Sub
Counting various things and show	Sub CountNonBlankCells() 'Returns a count of non-blank cells in a selection
the results in a Message Box	Dim myCount As Integer 'using the CountA ws function (all non-blanks)
	myCount = Application.CountA(Selection)
	MsgBox "The number of non-blank cell(s) in this selection is : "_
	& myCount, vbInformation, "Count Cells"
	End Sub
	Sub CountNonBlankCells2() 'Returns a count of non-blank cells in a selection
	Dim myCount As Integer 'using the Count ws function (only counts numbers, no text)
	myCount = Application.Count(Selection)
	MsgBox "The number of non-blank cell(s) containing numbers is : "_
	& myCount, vbInformation, "Count Cells"
	End Sub
	Sub CountAllCells 'Returns a count of all cells in a selection
	Dim myCount As Integer 'using the Selection and Count properties
	myCount = Selection.Count
	MsgBox "The total number of cell(s) in this selection is : "_
	& myCount, vbInformation, "Count Cells"
	End Sub
	Sub CountRows() 'Returns a count of the number of rows in a selection
	Dim myCount As Integer 'using the Selection & Count properties & the Rows method
	myCount = Selection.Rows.Count
	MsgBox "This selection contains " & myCount & " row(s)", vbInformation, "Count Rows"
	End Sub
	Sub CountColumns() 'Returns a count of the number of columns in a selection
	Dim myCount As Integer 'using the Selection & Count properties & the Columns method
	myCount = Selection.Columns.Count
	MsgBox "This selection contains " & myCount & " columns", vbInformation, "Count Columns"
	End Sub
	Sub CountColumnsMultipleSelections() 'Counts columns in a multiple selection
	AreaCount = Selection.Areas.Count
	If AreaCount <= 1 Then
	MsgBox "The selection contains " & _
	Selection.Columns.Count & " columns."
	Else
	For i = 1 To AreaCount
	MsgBox "Area " & i & " of the selection contains " & _
	Selection.Areas(i).Columns.Count & " columns."
	Next i
	End If
	End Sub
	Sub addAmtAbs()
	Set myRange = Range("Range1") 'Substitute your range here
	mycount = Application.Count(myRange)
	ActiveCell.Formula = "=SUM(B1:B" & mycount & ")" 'Substitute your cell address here
	End Sub
	Sub addAmtRel()
	Set myRange = Range("Range1") ' Substitute your range here
	mycount = Application.Count(myRange)
	ActiveCell.Formula = "=SUM(R[" & -mycount & "]C:R[-1]C)" 'Substitute your cell address here
	End Sub
Selecting: handy subs for doing	Sub SelectDown()
different types of selecting	Range(ActiveCell, ActiveCell.End(xlDown)).Select
	End Sub
	Sub Select_from_ActiveCell_to_Last_Cell_in_Column()
	Dim topCel As Range
	Dim bottomCel As Range
	On Error GoTo errorHandler
	Set topCel = ActiveCell
	Set bottomCel = Cells((65536), topCel.Column).End(xlUp)
	If bottomCel.Row >= topCel.Row Then
	Range(topCel, bottomCel).Select
	End If
	Exit Sub
	errorHandler:
	MsgBox "Error no. " & Err & " - " & Error
	End Sub
	Sub SelectUp()
	Range(ActiveCell, ActiveCell.End(xlUp)).Select
	End Sub
	Sub SelectToRight()
	Range(ActiveCell, ActiveCell.End(xlToRight)).Select
	End Sub
	Sub SelectToLeft()
	Range(ActiveCell, ActiveCell.End(xlToLeft)).Select
	End Sub
	Sub SelectCurrentRegion()
	ActiveCell.CurrentRegion.Select
	End Sub
	Sub SelectActiveArea()
	Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select
	End Sub
	Sub SelectActiveColumn()
	If IsEmpty(ActiveCell) Then Exit Sub
	On Error Resume Next
	If IsEmpty(ActiveCell.Offset(-1, 0)) Then _
	Set TopCell = ActiveCell Else Set TopCell = ActiveCell.End(xlUp)
	If IsEmpty(ActiveCell.Offset(1, 0)) Then _
	Set BottomCell = ActiveCell Else Set BottomCell = ActiveCell.End(xlDown)
	Range(TopCell, BottomCell).Select
	End Sub
	Sub SelectActiveRow()
	If IsEmpty(ActiveCell) Then Exit Sub
	On Error Resume Next
	If IsEmpty(ActiveCell.Offset(0, -1)) Then _
	Set LeftCell = ActiveCell Else Set LeftCell = ActiveCell.End(xlToLeft)
	If IsEmpty(ActiveCell.Offset(0, 1)) Then _
	Set RightCell = ActiveCell Else Set RightCell = ActiveCell.End(xlToRight)
	Range(LeftCell, RightCell).Select
	End Sub
	Sub SelectEntireColumn()
	Selection.EntireColumn.Select
	End Sub
	Sub SelectEntireRow()
	Selection.EntireRow.Select
	End Sub
	Sub SelectEntireSheet()
	Cells.Select
	End Sub
	Sub ActivateNextBlankDown()
	ActiveCell.Offset(1, 0).Select
	Do While Not IsEmpty(ActiveCell)
	ActiveCell.Offset(1, 0).Select
	Loop
	End Sub
	Sub ActivateNextBlankToRight()
	ActiveCell.Offset(0, 1).Select
	Do While Not IsEmpty(ActiveCell)
	ActiveCell.Offset(0, 1).Select
	Loop
	End Sub
	Sub SelectFirstToLastInRow()
	Set LeftCell = Cells(ActiveCell.Row, 1)
	Set RightCell = Cells(ActiveCell.Row, 256)
	If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight)
	If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft)
	If LeftCell.Column = 256 And RightCell.Column = 1 Then _
	ActiveCell.Select Else Range(LeftCell, RightCell).Select
	End Sub
	Sub SelectFirstToLastInColumn()
	Set TopCell = Cells(1, ActiveCell.Column)
	Set BottomCell = Cells(16384, ActiveCell.Column)
	If IsEmpty(TopCell) Then Set TopCell = TopCell.End(xlDown)
	If IsEmpty(BottomCell) Then Set BottomCell = BottomCell.End(xlUp)
	If TopCell.Row = 16384 And BottomCell.Row = 1 Then _
	ActiveCell.Select Else Range(TopCell, BottomCell).Select
	End Sub
	Sub SelCurRegCopy()
	Selection.CurrentRegion.Select
	Selection.Copy
	Range("A17").Select ' Substitute your range here
	ActiveSheet.Paste
	Application.CutCopyMode = False
	End Sub
Listing: Various listing subs	Sub ListFormulas()
	Dim counter As Integer
	Dim i As Variant
	Dim sourcerange As Range
	Dim destrange As Range
	Set sourcerange = Selection.SpecialCells(xlFormulas)
	Set destrange = Range("M1") 'Substitute your range here
	destrange.CurrentRegion.ClearContents
	destrange.Value = "Address"
	destrange.Offset(0, 1).Value = "Formula"
	If Selection.Count > 1 Then
	For Each i In sourcerange
	counter = counter + 1
	destrange.Offset(counter, 0).Value = i.Address
	destrange.Offset(counter, 1).Value = "'" & i.Formula
	Next
	ElseIf Selection.Count = 1 And Left(Selection.Formula, 1) = "=" Then
	destrange.Offset(1, 0).Value = Selection.Address
	destrange.Offset(1, 1).Value = "'" & Selection.Formula
	Else
	MsgBox "This cell does not contain a formula"
	End If
	destrange.CurrentRegion.EntireColumn.AutoFit
	End Sub
	Sub AddressFormulasMsgBox()	Displays the address and formula in
	For Each Item In Selection	message box.
	If Mid(Item.Formula, 1, 1) = "=" Then
	MsgBox "The formula in " & Item.Address(rowAbsolute:=False, _
	columnAbsolute:=False) & " is: " & Item.Formula, vbInformation
	End If
	Next
	End Sub
Type of Sheet	Sub TypeSheet()
	MsgBox "This sheet is a " & TypeName(ActiveSheet)
	End Sub
Add New Sheet	Sub AddSheetWithNameCheckIfExists()	This sub adds a new worksheet, names it
	Dim ws As Worksheet	based on a string in cell A1 of Sheet 1,
	Dim newSheetName As String	checks to see if sheet name already exists
	newSheetName = Sheets(1).Range("A1")	(if so it quits) and places it as the last
	For Each ws In Worksheets	worksheet in the workbook.
	If ws.Name = newSheetName Or newSheetName = _	A couple of variations of this follow.
	"" Or IsNumeric(newSheetName) Then	The first one creates a new sheet and then
	MsgBox "Sheet exists or name is invalid", vbInformation	copies some information from Sheet1 to
	Exit Sub	the new sheet. The next one creates a new
	End If	sheet which is a clone of Sheet1 with a
	Next	new name.
	Sheets.Add Type:="Worksheet"
	With ActiveSheet
	.Move after:=Worksheets(Worksheets.Count)
	.Name = newSheetName
	End With
	End Sub
	Sub Add_Sheet()
	Dim wSht As Worksheet
	Dim shtName As String
	shtName = Format(Now, "mmmm_yyyy")
	For Each wSht In Worksheets
	If wSht.Name = shtName Then
	MsgBox "Sheet already exists... Make necessary " & "corrections and try again."
	Exit Sub
	End If
	Next wSht
	Sheets.Add.Name = shtName
	Sheets(shtName).Move After:=Sheets(Sheets.Count)
	Sheets("Sheet1").Range("A1:A5").Copy Sheets(shtName).Range("A1")
	End Sub
	Sub Copy_Sheet()
	Dim wSht As Worksheet
	Dim shtName As String
	shtName = "NewSheet"
	For Each wSht In Worksheets
	If wSht.Name = shtName Then
	MsgBox "Sheet already exists... Make necessary " & "corrections and try again."
	Exit Sub
	End If
	Next wSht
	Sheets(1).Copy before:=Sheets(1)
	Sheets(1).Name = shtName
	Sheets(shtName).Move After:=Sheets(Sheets.Count)
	End Sub
Reset Values	Sub ResetValuesToZero2()
	For Each n In Worksheets("Sheet1").Range("WorkArea1")
	If n.Value <> 0 Then
	n.Value = 0
	End If
	Next n
	End Sub
	Sub ResetTest1()
	For Each n In Range("B1:G13")
	If n.Value <> 0 Then
	n.Value = 0
	End If
	Next n
	End Sub
	Sub ResetTest2()
	For Each n In Range("A16:G28")
	If IsNumeric(n) Then
	n.Value = 0
	End If
	Next n
	End Sub
	Sub ResetTest3()
	For Each amount In Range("I1:I13")
	If amount.Value <> 0 Then
	amount.Value = 0
	End If
	Next amount
	End Sub
	Sub ResetTest4()
	For Each n In ActiveSheet.UsedRange
	If n.Value <> 0 Then
	n.Value = 0
	End If
	Next n
	End Sub
	Sub ResetValues()
	On Error GoTo ErrorHandler
	For Each n In ActiveSheet.UsedRange
	If n.Value <> 0 Then
	n.Value = 0
	End If
	TypeMismatch:
	Next n
	ErrorHandler:
	If Err = 13 Then 'Type Mismatch
	Resume TypeMismatch
	End If
	End Sub
	Sub ResetValues2()
	For i = 1 To Worksheets.Count
	On Error GoTo ErrorHandler
	For Each n In Worksheets(i).UsedRange
	If IsNumeric(n) Then
	If n.Value <> 0 Then
	n.Value = 0
	ProtectedCell:
	End If
	End If
	Next n
	ErrorHandler:
	If Err = 1005 Then
	Resume ProtectedCell
	End If
	Next i
	End Sub
Using Input Boxes and Message	Sub CalcPay()
Boxes	On Error GoTo HandleError
	Dim hours
	Dim hourlyPay
	Dim payPerWeek
	hours = InputBox("Please enter number of hours worked", "Hours Worked")
	hourlyPay = InputBox("Please enter hourly pay", "Pay Rate")
	payPerWeek = CCur(hours * hourlyPay)
	MsgBox "Pay is: " & Format(payPerWeek, "$##,##0.00"), , "Total Pay"
	HandleError:
	End Sub
OnEntry Eigenschaft	Sub Auto_Open()	The Auto_Open sub calls the Action sub.
	ActiveSheet.OnEntry = "Action"
	End Sub
	Sub Action()	The font is set to bold in the ActiveCell if the
	If IsNumeric(ActiveCell) Then	value is >= 500. Thus if the value is >=500,
	ActiveCell.Font.Bold = ActiveCell.Value >= 500	then ActiveCell.Font.Bold = True.
	End If	If the value is less than 500, then
	End Sub	ActiveCell.Font.Bold = False.
	Sub Auto_Close()	The Auto_Close sub "turns off" OnEntry.
	ActiveSheet.OnEntry = ""
	End Sub
Enter the Value of a Formula	Sub GetSum() ' using the shortcut approach	To place the value (result) of a formula into
	[A1].Value = Application.Sum([E1:E15])	a cell rather than the formula itself.
	End Sub
	Sub EnterChoice()
	Dim DBoxPick As Integer
	Dim InputRng As Range
	Dim cel As Range
	DBoxPick = DialogSheets(1).ListBoxes(1).Value
	Set InputRng = Columns(1).Rows
	For Each cel In InputRng
	If cel.Value = "" Then
	cel.Value = Application.Index([InputData!StateList], DBoxPick, 1)
	End
	End If
	Next
	End Sub
Adding Range Names	Sub AddName1()
	ActiveSheet.Names.Add Name:="MyRange1", RefersTo:="=$A$1:$B$10"
	End Sub
	Sub AddName2() ' To add a range name based on a selection.
	ActiveSheet.Names.Add Name:="MyRange2", RefersTo:="=" & Selection.Address()
	End Sub
	Sub AddName3() ' To add a range name based on a selection using a variable.
	Dim rngSelect As String
	rngSelect = Selection.Address
	ActiveSheet.Names.Add Name:="MyRange3", RefersTo:="=" & rngSelect
	End Sub
	Sub AddName4() ' To add a range name based on a selection (shortest version)
	Selection.Name = "MyRange4"
	End Sub
For-Next For-Each Loops	Sub Accumulate() 'You might want to step through this using the "Watch" feature
	Dim n As Integer
	Dim t As Integer
	For n = 1 To 10
	t = t + n
	Next n
	MsgBox "The total is " & t
	End Sub
	Sub CheckValues1() 'Checks values in a range 10 rows by 5 columns moving left to right, top to bottom
	Dim rwIndex As Integer
	Dim colIndex As Integer
	For rwIndex = 1 To 10
	For colIndex = 1 To 5
	If Cells(rwIndex, colIndex).Value <> 0 Then Cells(rwIndex, colIndex).Value = 0
	Next colIndex
	Next rwIndex
	End Sub
	Sub CheckValues2() 'Same as above using the "With" statement instead of "If"
	Dim rwIndex As Integer
	Dim colIndex As Integer
	For rwIndex = 1 To 10
	For colIndex = 1 To 5
	With Cells(rwIndex, colIndex)
	If Not (.Value = 0) Then Cells(rwIndex, colIndex).Value = 0
	End With
	Next colIndex
	Next rwIndex
	End Sub
	Sub CheckValues3() 'Same as CheckValues1 except moving top to bottom, left to right
	Dim colIndex As Integer
	Dim rwIndex As Integer
	For colIndex = 1 To 5
	For rwIndex = 1 To 10
	If Cells(rwIndex, colIndex).Value <> 0 Then Cells(rwIndex, colIndex).Value = 0
	Next rwIndex
	Next colIndex
	End Sub
	Sub EnterInfo() 'Enters a value in 10 cells in a column and then sums the values
	Dim i As Integer
	Dim cel As Range
	Set cel = ActiveCell
	For i = 1 To 10
	cel(i).Value = 100
	Next i
	cel(i).Value = "=SUM(R[-10]C:R[-1]C)"
	End Sub
	Sub Reset_Values_All_WSheets()
	Dim wSht As Worksheet	Loop through all worksheets in workbook
	Dim myRng As Range	and reset values in a specific range
	Dim allwShts As Sheets	on each sheet.
	Dim cel As Range
	Set allwShts = Worksheets
	For Each wSht In allwShts
	Set myRng = wSht.Range("A1:A5, B6:B10, C1:C5, D4:D10")
	For Each cel In myRng
	If Not cel.HasFormula And cel.Value <> 0 Then
	cel.Value = 0
	End If
	Next cel
	Next wSht
	End Sub
Hide / UnHide Sheets	Sub Hide_WS1() 'To hide specific worksheet	Distinction between Hide(False) and
	Worksheets(2).Visible = Hide ' you can use Hide or False	xlVeryHidden:
	End Sub	Visible = xlVeryHidden - Sheet/Unhide
		is grayed out. To unhide sheet you set the
		Visible property to True.
	Sub Hide_WS2() 'To make worksheet very hidden	Visible = Hide(or False) - Sheet/Unhide is
	Worksheets(2).Visible = xlVeryHidden	not grayed out.
	End Sub
	Sub UnHide_WS() 'To unhide a specific worksheet
	Worksheets(2).Visible = True
	End Sub
	Sub Toggle_Hidden_Visible() 'To toggle between hidden and visible
	Worksheets(2).Visible = Not Worksheets(2).Visible
	End Sub
	Sub Un_Hide_All() 'To set the visible property to True on ALL sheets in workbook
	Dim sh As Worksheet
	For Each sh In Worksheets
	sh.Visible = True
	Next
	End Sub
	Sub xlVeryHidden_All_Sheets() 'To set the visible property to xlVeryHidden on ALL sheets in workbook
	On Error Resume Next 'The last "hide" will fail because you can not hide every sheet in a workbook
	Dim sh As Worksheet
	For Each sh In Worksheets
	sh.Visible = xlVeryHidden
	Next
	End Sub
Find and select a series of dates	Sub FindDates()
(based on month & year)	On Error GoTo errorHandler
	Dim startDate As String
	Dim stopDate As String
	Dim startRow As Integer
	Dim stopRow As Integer
	startDate = InputBox("Enter the Start Date: (mm/dd/yy)")
	If startDate = "" Then End
	stopDate = InputBox("Enter the Stop Date: