auxmoney - Geld leihen für das Studiumauxmoney - Geld leihen für das Studium

auxmoney - Geld leihen für den Umzugauxmoney - Geld leihen für den Umzug

VBA-Makros für Excel (Teil III)

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: (mm/dd/yy)")
If stopDate = "" Then End
startDate = Format(startDate, "mm/??/yy")
stopDate = Format(stopDate, "mm/??/yy")
startRow = Worksheets("Table").Columns("A").Find(startDate, _
lookin:=xlValues, lookat:=xlWhole).Row
stopRow = Worksheets("Table").Columns("A").Find(stopDate, _
lookin:=xlValues, lookat:=xlWhole).Row
Worksheets("Table").Range("A" & startRow & ":A" & _ Copy the selection to another worksheet.
stopRow).Copy destination:=Worksheets("Report").Range("A1")
End
errorHandler:
MsgBox "There has been an error: " & Error() & Chr(13) & "Ending Sub.......Please try again", 48
  End Sub  
Arrays Sub MyTestArray()
Dim myCrit(1 To 4) As String ' Declaring array and setting bounds
Dim Response As String
Dim i As Integer
Dim myFlag As Boolean
myFlag = False
myCrit(1) = "A" 'To fill array with values
myCrit(2) = "B"
myCrit(3) = "C"
myCrit(4) = "D" Check if Response matches anything in
Do Until myFlag = True array.
Response = InputBox("Please enter your choice: (i.e. A, B, C or D)")
For i = 1 To 4 'UCase ensures that Response and myCrit are the same case.
If UCase(Response) = UCase(myCrit(i)) Then
myFlag = True: Exit For
End If
Next i
Loop
  End Sub  
Replace Information in all work- Sub ChgInfo() Replace "old stuff" and "new stuff" with your
sheets of the workbook Dim Sht As Worksheet info.
For Each Sht In Worksheets
Sht.Cells.Replace What:="old stuff", Replacement:="new stuff", LookAt:=xlPart, MatchCase:=False
Next
  End Sub  
Move Minus Sign from the right- Sub MoveMinus()
hand side changing a text string On Error Resume Next
into a value Dim cel As Range
Dim myVar As Range
Set myVar = Selection
For Each cel In myVar
If Right((Trim(cel)), 1) = "-" Then
cel.Value = cel.Value * 1
End If
Next
With myVar
.NumberFormat = "#,##0.00_);[Red](#,##0.00)"
.Columns.AutoFit
End With
  End Sub  
Change Events Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Application.EnableEvents = False This is a simple sub that changes what
Target = UCase(Target) you type in a cell to upper case.
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
On Error Resume Next This sub shows a UserForm if the user
Set myRange = Intersect(Range("A1:A10"), Target) selects any cell in myRange.
If Not myRange Is Nothing Then
UserForm1.Show
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
On Error GoTo iQuitz In this example, Sheets("Table") contains,
Dim cel As Range, tblRange As Range in Column A, a list of dates (for example
Set tblRange = Sheets("Table").Range("A1:A48") Mar-07), and in Column B, an amount
Application.EnableEvents = False for Mar-07. If you enter Mar-07 in Sheet1,
For Each cel In tblRange it places the amount for March in the
If UCase(cel) = UCase(Target) Then cell to the right. The sub below is in the
With Target(1, 2) code section of Sheet1.
.Value = cel(1, 2).Value
.NumberFormat = "#,##0.00_);[Red](#,##0.00)"
End With
Columns(Target(1, 2).Column).AutoFit
Exit For
End If
Next
iQuitz:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target _ If you select a cell in a column that contains
As Excel.Range) values, the total of all the values in the
Dim myVar As Double column will show in the statusbar.
myVar = Application.Sum(Columns(Target.Column))
If myVar <> 0 Then
Application.StatusBar = Format(myVar, "###,###")
Else
Application.StatusBar = False
End If
  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