by ankush mago (1 Submission)
Category: Custom Controls/Forms/Menus
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Tue 9th September 2008
Date Added: Mon 8th February 2021
Rating: (1 Votes)
short cut for xl sheets.
a = Range("sname").Value
If Range(a).Value = Range("switch1").Value Then
Range(a).Value = Range("switch2").Value
Else
Range(a).Value = Range("switch1").Value
End If
Application.Calculate
End Sub
Sub Prepare()
Dim sheet As Worksheet
i = 3
Worksheets("Manager").Select
Range("PrintQuery").Select
For Each sheet In ActiveWorkbook.Worksheets
Range("PrintQuery").Cells(i, 0).Value = sheet.Name
If sheet.Visible Then
Range("PrintQuery").Cells(i, 1).Value = 1
Else
Range("PrintQuery").Cells(i, 1).Value = 0
End If
i = i + 1
Range("PrintQuery").Value = i - 3
Next sheet
End Sub
Sub HideUnhide()
For i = 3 To 2 + Range("PrintQuery").Value
If Range("PrintQuery").Cells(i, 1) = 1 Then
Worksheets(Range("PrintQuery").Cells(i, 0).Value).Visible = True
Else
Worksheets(Range("PrintQuery").Cells(i, 0).Value).Visible = False
End If
Next i
End Sub
Sub Choose()
For i = 3 To 2 + Range("PrintQuery").Value
If Range("PrintQuery").Cells(i, 2) = 1 Then
Worksheets(Range("PrintQuery").Cells(i, 0).Value).Visible = True
Worksheets(Range("PrintQuery").Cells(i, 0).Value).Select (False)
End If
Next i
End Sub
Sub PrintSheets()
Application.Calculate
For i = 3 To 2 + Range("PrintQuery").Value
If Range("PrintQuery").Cells(i, 2) = 1 Then
Worksheets(Range("PrintQuery").Cells(i, 0).Value).Visible = True
Worksheets(Range("PrintQuery").Cells(i, 0).Value).Select
Text = Range("A1").Value
If InStr(Text, "_") <> 0 Then
j = 1
While j <> Len(Text)
k = InStr(j + 1, Text, "_")
' MsgBox (Mid(Text, j + 1, k - j))
With ActiveSheet.PageSetup
.CenterHorizontally = True
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Range(Mid(Text, j + 1, k - j - 1)).PrintOut Copies:=1
j = k
Wend
End If
End If
If Range("PrintQuery").Cells(i, 1) = 1 Then
Worksheets(Range("PrintQuery").Cells(i, 0).Value).Visible = True
Else
Worksheets(Range("PrintQuery").Cells(i, 0).Value).Visible = False
End If
Next i
End Sub
Sub GotoHyp()
If ActiveSheet.Name = "Assumptions" Then
Worksheets(Range("LASTWORK").Value).Select
Else
Range("LASTWORK").Value = ActiveSheet.Name
Worksheets("Assumptions").Select
End If
End Sub
Function dec(tot, x) As Double
dec = (tot + 1) * x
End Function
Sub affiche()
Range("ALLSHEETS").Value = 1
End Sub
Sub efface()
Range("ALLSHEETS").Clear
Range("ALLSHEETS").Cells(3, 1).Value = 1
Range("ALLSHEETS").Cells(5, 1).Value = 1
End Sub
Sub mille()
For i = 1 To Selection.Rows.Count
For j = 1 To Selection.Columns.Count
Selection.Cells(i, j).Value = Selection.Cells(i, j).Value * 0.001
Next j
Next i
End Sub
Sub moins()
For i = 1 To Selection.Rows.Count
For j = 1 To Selection.Columns.Count
Selection.Cells(i, j).Value = -Selection.Cells(i, j).Value
Next j
Next i
End Sub
Sub page()
On Error GoTo suite
re: ActiveCell.Cells(-0, 1).Activate
GoTo re
suite: While (ActiveCell.Value = "" Or Mid(ActiveCell.Value, 1, 1) = "_")
ActiveCell.Cells(1, 0).Activate
Wend
Range(ActiveCell.Value).Select
End Sub
Sub printselection()
Selection.PrintOut
End Sub
Sub PrintselectionV()
ActiveSheet.PageSetup.Orientation = xlPortrait
Selection.PrintOut
ActiveSheet.PageSetup.Orientation = xlLandscape
End Sub
Sub insertligne()
Set Rightcell = ActiveCell
Set Leftcell = ActiveCell
While (Rightcell.Offset(0, 1).Interior.ColorIndex = xlNone)
Set Rightcell = Rightcell.Offset(0, 1)
Wend
While (Leftcell.Offset(0, -1).Interior.ColorIndex = xlNone)
Set Leftcell = Leftcell.Offset(0, -1)
Wend
Range(Leftcell.Address, Rightcell.Address).Insert Shift:=xlDown
End Sub
Sub retireligne()
Set Rightcell = ActiveCell
Set Leftcell = ActiveCell
While (Rightcell.Offset(0, 1).Interior.ColorIndex = xlNone)
Set Rightcell = Rightcell.Offset(0, 1)
Wend
While (Leftcell.Offset(0, -1).Interior.ColorIndex = xlNone)
Set Leftcell = Leftcell.Offset(0, -1)
Wend
Range(Leftcell.Address, Rightcell.Address).Delete Shift:=xlUp
End Sub
Sub PrintLocal()
Set Rightcell = ActiveCell
Set Leftcell = ActiveCell
While (Rightcell.Offset(0, 1).Interior.ColorIndex = xlNone)
Set Rightcell = Rightcell.Offset(0, 1)
Wend
While (Rightcell.Offset(1, 0).Interior.ColorIndex = xlNone)
Set Rightcell = Rightcell.Offset(1, 0)
Wend
While (Leftcell.Offset(0, -1).Interior.ColorIndex = xlNone)
Set Leftcell = Leftcell.Offset(0, -1)
Wend
While (Leftcell.Offset(-1, 0).Interior.ColorIndex = xlNone)
Set Leftcell = Leftcell.Offset(-1, 0)
Wend
Range(Leftcell.Address, Rightcell.Address).Select
'Application.Run Macro:="NewPrintScalePro"
End Sub
Sub calc()
ActiveSheet.Calculate
End Sub
Sub copyacross()
Range(ActiveCell.Address, ActiveCell.Cells(1, 2).Address).Select
Selection.Copy
Range(ActiveCell.Address, ActiveCell.Cells(1, 24).Address).Select
ActiveSheet.Paste
End Sub