Search VBA Code here

Friday
Jul202007

Declare and populate a Dynamic Array: VBA Excel

Private ccArray(1 To Range(Somerange.column).Count, 1 To 7) As Variant  'Declare

Dim i As Range
Dim NDX As Long
Dim RDX As Integer

 For Each i In Range(somerange) 'Populate
        ccArray(NDX, RDX) = i.Value                                                         
            RDX = RDX + 1
Next i

Sunday
Jul152007

weekday or weekend sheet formula: Formula Excel

=IF=1,R2-3,IF=7,R2-2,R2-1))

Sunday
Jul152007

Create a time delay (pause): VBA Excel

Private Sub Workbook_Open()
Application.OnTime EarliestTime:= _
Now + TimeValue("00:00:08"), Procedure:="EndSplash"
UserForm1.Show
End Sub

Sunday
Jul152007

Select certain sheets in workbook: VBA Excel

Sub SelectSheets()
    For Each sht In Sheets
        If TypeName(sht) = "Chart" Then sht.Select False
    Next sht
End Sub

Sunday
Jul152007

Select first empty cell: VBA Excel

Range("A65536").End(xlup).Offset(1,0)

Sunday
Jul152007

Example of retreiving values from registry: VBA Excel

 Sub Read_registry_Value()
    Dim Shell As Object
    Dim keyname As String
    Dim value As String
    Dim keyvalue As String

 

    keyname = "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\" & _
              "Control\ComputerName\ActiveComputerName\"
             

    value = "ComputerName"

 

    Set Shell = CreateObject("wscript.shell")
    On Error Resume Next
    keyvalue = Shell.regread(keyname & value)
    If Err.Number 0 Then
        MsgBox "Invalid Registry Entry"
    Else
        MsgBox keyvalue
    End If
    On Error GoTo 0
End Sub

 

Sunday
Jul152007

Rename lots of sheets: VBA Excel

Private Sub cmdOK_Click()
    Dim Naming As String, daBooks As Long, daPath As String
    Dim ActingBook As String
    usrTabs2Books.Hide
   
    daPath = ActiveWorkbook.Path  'Get current path
    ActingBook = ActiveWorkbook.Name
    Application.ScreenUpdating = False
    For daBooks = 1 To Workbooks(ActingBook).Worksheets.Count 'Count Sheets
        If optFront = True Then  'Where to put the naming conv
            Naming = txtNamingConvention.Text & "-" & Sheets(daBooks).Name
        Else
            Naming = Sheets(daBooks).Name & "-" & txtNamingConvention.Text
        End If
        Sheets(daBooks).Select
        Sheets(daBooks).Copy  'Copy the sheet to new workbook
        Application.DisplayAlerts = False 'Turn OFF alerts
        ActiveWorkbook.SaveAs Filename:=daPath & "\" & Naming & ".xls", FileFormat:= _
        xlNormal   'Name it
        ActiveWorkbook.Close  'Close new workbook
        Application.DisplayAlerts = True 'Alerts back ON
    Next
    Application.ScreenUpdating = True
    MsgBox "Completed splitting " & daBooks & " sheets to " & daPath, _
        vbInformation, "Progress"
End Sub