NFL Gambling News, Pro and College Links , Advice, Picks.

new : 16.3.
Sub test_this()
sel_case = InputBox("gib test Nr ein : 1-26: ", "nicht alles geht")
Select Case sel_case
Case Is = 1: Call user
Case Is = 2: Call get_answer
Case Is = 3: Call get_answer2
Case Is = 4: Call convert_formulas
Case Is = 5: Call datacontent
Case Is = 6: Call screen_update
Case Is = 7: Call check_cell
Case Is = 8: Call selective_format
' Case Is = 9: Call top_avg
Case Is = 10: Call process_cells
Case Is = 11: Call select_row
Case Is = 12: Call select_column
Case Is = 13: Call diverses
Case Is = 14: Call copy_range
Case Is = 15: Call clear_contents
Case Is = 16: Call act_diverses
Case Is = 17: Call named_ranges_examples
Case Is = 18: Call cell_properties_examples
Case Is = 19: Call loop1
Case Is = 20: Call loop2
Case Is = 21: Call with_selection
Case Is = 22: Call Current_region
Case Is = 23: Call duplicate_values_in_col
Case Is = 24: Call select_special_cells
Case Is = 25: Call error_codes_check
Case Is = 26: Call character_boldred
' Case Is = 27: Call repl_formula_specificPos
Case Is = 28: Call stitute_test
Case Is = 29: Call character_boldred
Case Is = 30: Call transpose
Case Is = 31: Call end_of_row_or_col
Case Is > 31: MsgBox "other case"
End Select
End Sub
Sub get_answer() '2
config = vbYesNo + vbQuestion + vbDefaultButton2
ans = MsgBox("Do it", config)
If ans = vbYes Then GoTo run_yes
If ans = vbNo Then GoTo end_sub
'
run_yes:
MsgBox "do here"
Exit Sub
end_sub:
MsgBox "do nothing"
End Sub
Function user() '1
' defs: ALT+ F11 opens VBA

user = Application.UserName
End Function


Sub get_answer2() '3
msg = "do you ...."
msg = msg & vbLf + vbLf
msg = msg & "more in this line"
Title = "Msg Title"
config = vbYesNo + vbQuestion + vbDefaultButton2
ans = MsgBox(msg, config, Title)
If ans = vbYes Then GoTo run_yes
If ans = vbNo Then GoTo end_sub
'
run_yes:
MsgBox "do here"
Exit Sub
end_sub:
MsgBox "do nothing"

End Sub

Sub convert_formulas() '4
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, transpose:=False
Application.CutCopyMode = False
End Sub

Sub datacontent() '5
data = Worksheets("sheet2").Range("a1").Value
MsgBox "row :" & ActiveCell.Row
MsgBox "col" & ActiveCell.Column
MsgBox "a1 = " & data

'
End Sub
Sub screen_update() '6
Application.ScreenUpdating = False ' true
End Sub

Sub check_cell() '7
Worksheets("sheet2").Activate
Range("c7").Select

Select Case ActiveCell.Value
Case Is < 0
ActiveCell.Font.Color = vbRed
Case 0
ActiveCell.Font.Color = vbBlue
Case Is > 0
ActiveCell.Font.Color = vbBlack
End Select
MsgBox "done"
End Sub

Sub selective_format() '8
Message = "message text"
target = InputBox(Message) ' get a target to compare
If target = "" Then GoTo end1
If TypeName(Selection) <> "Range" Then GoTo end2
target = Val(target) ' string to value
' evaluate cells-items
For Each Item In Selection
If IsNumeric(Item) Then
If Item.Value > target Then
With Item.Value
.Font.Bold = True 'set bold
.Font.ColorIndex = 3 ' red / vbred
End With
End If
End If
Next Item
Exit Sub
end1:
MsgBox "end 1"
Exit Sub
end2:
MsgBox "not Range. end2"
End Sub
Public Function name(argumentlist) As String 'examp
End Function
Private Function name2(argumentlist) As String 'examp
End Function
Static Function name3(argumentlist, argu2) As String 'examp
End Function
Function top_avg(inrange, num) '9
Sum = 0
For i = 1 To num
Sum = Sum + WorksheetFunction.Large(inrange, 1)
Next i
topavg = Sum / num
Exit Function
End Function
Sub process_cells() ' loops 10 error
' select outside the cells to loop
For Each Cell In Selection
If c.Value < 0 Then c.Font.Color = vbRed 'example
Next Cell
End Sub
Sub select_column() ' 12
ActiveCell.EntireColumn.Select
End Sub
Sub select_row() '11
ActiveCell.EntireRow.Select
With Selection
.Font.Bold = True
End With
End Sub
Sub diverses()
' Set rate = Workbook("wb").Worksheets("sheet2").Range("tab_all").Value
' variable = rate
' Dim rate As Range
'
'
'
' On Error Resume Next
' On Error GoTo XXXX
'
'
MsgBox "diverses see here"
End Sub

Sub copy_range() ' 14 error

Worksheet("sheet2").Range("a1:a5").Copy Range("f1:f5")
MsgBox Range("f1").Value
End Sub

Sub clear_contents() '15
Worksheets("sheet2").Range("f1:f12").ClearContents
Range("total").Clear
End Sub
Sub act_diverses() '16 error
Worksheets("sheet2").Activate
' ActiveCell.Row
' ActiveCell.Rows
ActiveSheet.Select
' ActiveCell.Column
' ActiveCell.Columns
End Sub

Sub named_ranges_examples() '17
' examples from help-text
' Referring to a Named Range
MsgBox "must be open"
' Range("_VBA-collection.xls!sheet1!criteria").Font.Italic = True

'
' Range("['_VBA-collection.xls]sheet2!taball").BorderAround Weight:=xlThin
'
'
Application.Goto Reference:="taball"
Selection.ClearContents
' in active workbook
Application.Goto Reference:="MyRange"
Selection.ClearContents
'
' Looping Through Cells in a Named Range
Const limit As Integer = 25
For Each c In Range("My2Range")
If c.Value > limit Then
c.Interior.ColorIndex = 27 'yellow
End If
Next c
MsgBox "my2range changed "

'
For counter = 1 To 20
Set curCell = Worksheets("sheet2").Cells(counter, 3)
If Abs(curCell.Value) < 0.01 Then curCell.Value = 0
Next counter
' same as :
For Each c In Worksheets("sheet2").Range("c1:D10").Cells
If Abs(c.Value) < 0.01 Then c.Value = 0
Next
' same as:
For Each c In ActiveCell.CurrentRegion.Cells
If Abs(c.Value) < 0.01 Then c.Value = 0
Next
End Sub
Sub cell_properties_examples() ' 18
'
Worksheets("sheet2").Activate
Range("J1:L8").Formula = "=rand()" 'Range is on the active sheet
'
'
MsgBox "J1:L8 formula setted"
Worksheets(1).Activate
Range("criteria").ClearContents
MsgBox "criteria range clear contents done"
'
'
' cell-props
Worksheets(2).Activate
Worksheets(2).Cells(1, 1).Value = 24
'
ActiveSheet.Cells(3, 11).Formula = "=sum(B1:B5)"
MsgBox "sum formula setted C11 "

Worksheets("sheet2").Activate
For theYear = 1 To 5
Cells(1, theYear + 1).Value = 1990 + theYear
Next theYear
MsgBox "B1-F1 = year set"
For theQuarter = 1 To 4
Cells(theQuarter + 1, 1).Value = "Q" & theQuarter
Next theQuarter
MsgBox "A2-A5 = quater set"
'
MsgBox "sets the formula for cell C5"
Worksheets(1).Range("C5:C10").Cells(1, 1).Formula = "=rand()"
'
' border line style for cells 1:J10
With Worksheets(2)
.Range(.Cells(1, 1), .Cells(10, 10)).Borders.LineStyle = xlThick
End With
MsgBox "border thick set"
'
' Offset Property
'
Worksheets("sheet2").Activate 'can't select unless the sheet is active
Selection.Offset(3, 1).Range("A1").Select
'
'
' Union Method (mehrere ranges)
Dim r1 As Range, r2 As Range, myMultiAreaRange As Range
Worksheets("sheet2").Activate
Set r1 = Range("A1:B2")
Set r2 = Range("C3:D4")
Set myMultiAreaRange = Union(r1, r2)
myMultiAreaRange.Select
'
'
numberOfSelectedAreas = Selection.Areas.Count
MsgBox "numberOfSelectedAreas : " & numberOfSelectedAreas
If numberOfSelectedAreas > 2 Then
MsgBox "You cannot carry out this command on multi-area selections"
End If
'
MsgBox "done"
'
End Sub

Sub loop1() ' 19
Dim start As Integer
Dim end_count As Integer
Dim counter As Integer

counter = 0
start = 1
end_count = 10
For counter = start To end_count
' stmt1
MsgBox "counterloop1 : " & counter & "." & start & "." & end_count
' stmt2 - n
Next counter
'
End Sub
Sub loop2() '20
num = 0
For num = 1 To 10
' stmt1 - n
MsgBox num
Next num
End Sub
Sub with_selection() ' 21
With Selection
.Font.Color = vbRed
.Font.Bold = True
End With
MsgBox "selection is red/bold"
' same as :
Selection.Font.Color = vbBlack
Selection.Font.Bold = False
'
MsgBox "selection is black/normal"
End Sub
Sub Current_region() ' 22
MsgBox "make a selected region in sheet2 smaller(- head cell). set cursor in a cell "
Worksheets("sheet2").Activate
ActiveCell.CurrentRegion.Select
'
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select
'

End Sub
Sub duplicate_values_in_col() ' 23
'
Set r = Range("criteria")

For n = 1 To r.Rows.Count
If r.Cells(n, 1) = r.Cells(n + 1, 1) Then

MsgBox "Duplicate data in " & r.Cells(n + 1, 1).Address & " / " & n & " / " & r.Rows.Count
End If
Next n

End Sub
Sub end_of_row_or_col()
Range(ActiveCell, ActiveCell.End(xlDown)).Select

End Sub
Sub select_special_cells() ' 24
' skip blanks
On Error Resume Next
Set constantcells = Selection.SpecialCells(xlConstants, 23)
For Each Cell In constantcells
If Cell.Value > 0 Then Cell.Font.Bold = True
Next Cell
' formula - cells:
Set formulacells = Selection.SpecialCells(xlFormulas, 23)
For Each Cell In formulacells
If Cell.Value > 0 Then Cell.Font.Color = vbRed
Next Cell
End Sub
Sub character_boldred() ' 26
With Worksheets("sheet2").Range("c26")
.Value = "abcdefg"
.Characters(3, 1).Font.Bold = True
.Characters(2, 1).Font.Color = vbRed

End With

End Sub
Sub error_codes_check() ' 25
Worksheets("sheet2").Activate
If IsError(ActiveCell.Value) Then
errval = ActiveCell.Value
Select Case errval
Case CVErr(xlErrDiv0)
MsgBox "#DIV/0! error"
Case CVErr(xlErrNA)
MsgBox "#N/A error"
Case CVErr(xlErrName)
MsgBox "#NAME? error"
Case CVErr(xlErrNull)
MsgBox "#NULL! error"
Case CVErr(xlErrNum)
MsgBox "#NUM! error"
Case CVErr(xlErrRef)
MsgBox "#REF! error"
Case CVErr(xlErrValue)
MsgBox "#VALUE! error"
Case Else
MsgBox "This should never happen!!"
End Select
End If
End Sub

'Sub repl_formula_specificPos() '27
'MsgBox "see also cells B: + C: function: =REPLACE(D27;5;2;99) "
'Dim input_text As String
'Dim find_this As String
'Dim startpos As Integer
'Dim abc As String
'Dim replacement As String
'Dim count_long As Long
'input_text = " "
'find_this = "d"
'replacement = "#"
'count_long = 1
'startpos = 1
'input_text = InputBox("expression eingeben, -d- wird mit # replaced", "replace-function")
'abc = Replace(input_text, find_this, replacement, startpos, count_long, compare:=vbTextCompare)
'MsgBox abc
'End Sub

' _______________________________________
Sub stitute_test() '28
MsgBox "substitute excel function only : SUBSTITUTE(C28; 'cde'; 'ttt' ;3) "
d_text = "Quarter 1, 1991"
oldtext = "1"
seperat = "2"
' SUBSTITUTE(d_text, oldtext, seperat, 1) ' equals Quarter 1, 1992

End Sub
Sub transpose() '29
MsgBox " CELL function : TRANSPOSE($A$1:$C$1) "
End Sub