OfficeAfford

The Excel Page

 

Here are some of the routines we use everyday.


At Affordable Solutions, we pride ourselves in giving users the most complete information.
This is why we have developed a full series of Excel Tutorials:
Visit our Web-Site at http://www.affordsol.be for more information.

How to contact us!


CONTENTS

Databases in Excel Cells and their contents
Fields, Formulas, Array Formulas Files & Drives
Sheets & Applications Functions Multi Sheets Functions
Counting & Summing Date Functions
Miscellaneous

kilroy    Contents   

Excel Databases

kilroy    Contents   

Cells and their contents

kilroy    Contents   

SPECIAL: Fields, Formulas, Array Formulas

kilroy    Contents   

Files & Drives

kilroy    Contents   

Sheets & Applications Functions

kilroy    Contents   

Multi Sheets Functions

kilroy    Contents   

Counting & Summing

kilroy    Contents   

Date Functions

kilroy    Contents   

Miscellaneous

kilroy    Contents   

Public Sub ExportWorkBookAsTextFile()

'Writes the ActiveWorkbook as an ASCII Text File
   ActiveWorkbook.SaveAs Filename:="fully pathed destination file.txt", _
                                                  FileFormat:=xlText, _
                                                   CreateBackup:=False
End Sub

kilroy    Contents   

Public Sub FillCells()

'Fills the Sheet "YourTargetSheet"
'With var_inputX, where X iterates from 1 to nbelts%=nr of elements
'Use Value for numbers and Formula for text
   ActiveWorkbook.Sheets("YourTargetSheet").Select
   ActiveSheet.Range("A1").Activate
   For ptr% = 1 To nbelts%
      'some numbers: we use Value
      ActiveCell.Offset(ptr% -1, 0).Value = var_input1
      ActiveCell.Offset(ptr% - 1, 2).Value = var_input2
      'some text: we use Formula
      ActiveCell.Offset(ptr% - 1, 3).Formula = var_input3$
      ActiveCell.Offset(ptr% - 1, 4).Formula = "any text"
      ActiveCell.Offset(ptr% - 1, n).Value = var_inputn
   Next ptr%
End Sub

kilroy    Contents   

Public Sub Sort_a_Sheet()

             'a) Makes a Copy of Sheet "YourTargetSheet" at the end of the workbook
             'b) Renames the Copy to "AnyNewSheetName"
             'c) Selects the sheet "AnyNewSheetName"
             'd) Sorts the data of "AnyNewSheetName" according to "ColumnToSort"
             '    which will prevent our original data on Sheet "YourTargetSheet" from being changed !!
   ActiveWorkbook.Sheets("YourTargetSheet").Select
   ActiveSheet.Copy after:=Worksheets(Worksheets.Count)
   Worksheets(Worksheets.Count).Name = "AnyNewSheetName"
   ActiveWorkbook.Sheets("AnyNewSheetName").Select
   tstr1$ = ActiveSheet.UsedRange.Address
   str_taddr1 = "$A$9:$G$" & Right$(ActiveSheet.UsedRange.Address, Len(ActiveSheet.UsedRange.Address) - 8)
   Worksheets("AnyNewSheetName").Range(str_taddr1).Sort_
             key1:=Worksheets("AnyNewSheetName").Range("ColumnToSort")
End Sub

kilroy    Contents   

Public Function SizeRecordField(ByVal iptr As Integer, ByVal istr As String) As String

'Must have fieldlen%(1 to nbfields%) initialized
'Resizes istr according to fieldlen(iptr), padding with spaces at right
   tstr1$ = RTrim(istr): tint1% = Len(tstr1$)
   SizeRec = tstr1$ &String(fieldlen%(iptr) - tint1%, " ")
End Function

kilroy    Contents   

Public Sub WipeSheet()

'Deletes contents of all cells in "YourTargetSheet"
   Worksheets("YourTargetSheet").UsedRange.ClearContents
End Sub

kilroy    Contents   

Public Sub CloseApp()

'Closes the application
   Application.DisplayAlerts = False
   Application.Quit
EndSub

kilroy    Contents   

Public Sub dbcOn()

'Activates the routine "YourRoutine" on double-click action in "YourTargetSheet"
   ActiveWorkbook.Sheets("YourTargetSheet").OnDoubleClick = "YourRoutine"
End Sub

kilroy    Contents   

Public Sub dbcOff()

'Deactivates the routine "YourRoutine" on double-click action in "YourTargetSheet"
   ActiveWorkbook.Sheets("YourTargetSheet").OnDoubleClick = ""
End Sub

kilroy    Contents   

Public Sub SelectClient()

'This is an example of "YourRoutine" used in dbcon and dbcoff
   'Client is selected by a double_click in the sheet Clientshh
   'Let's see the address in the sheet ListCli
   Dim tformula, trow, taddr As String
   Dim tint As Integer
   taddr = ActiveCell.Address
   tint = Len(taddr)
   trow = Mid$(taddr, 4, tint - 3)
   selcli = trow
   Worksheets(1).Range("G8").Formula = Worksheets(2).Range("B" & selcli).Formula
   Worksheets(1).Range("H8").Formula = Worksheets(2).Range("C" & selcli).Formula
   Worksheets(1).Range("G9").Formula = Worksheets(2).Range("D" & selcli).Formula
   Worksheets(1).Range("G10").Formula = Worksheets(2).Range("E" & selcli).Formula
   tformula = Worksheets(2).Range("F" & selcli).Formula
   Worksheets(1).Range("D14").Formula = "BE " & Left$(tformula, 3) & " " & Mid$(tformula, 4, 3) & " " & Right$(tformula, 3)
   ActiveWorkbook.Sheets("Facturehh").Activate
   ActiveSheet.Range("B20").Select
End Sub

kilroy    Contents   

Public Sub ScrollRight()

'Scrolls the active window 1 step to the right (Small Scroll Right)
   ActiveWindow.SmallScroll ToRight:=1
End Sub

kilroy    Contents   

Public Sub ScrollLeft()

'Scrolls the active window 1 step to the left (Small Scroll Left)
   ActiveWindow.SmallScroll ToLeft:=1
End Sub

kilroy    Contents   

Public Sub PreviousRecord()

'Goes to next screen (Large Scroll Down)
   ActiveWindow.LargeScroll Down:=-1
End Sub

kilroy    Contents   

Public Sub NextRecord()

'Goes to next screen (Large Scroll Up)
   ActiveWindow.LargeScroll Up:=1
End Sub

kilroy    Contents   

Public Sub WriteDelimited()

'Writes an ASCII Comma Delimited Table where lines are terminated by CR + LF
'Must have txtfname$ and dbfname$ initialized as fully pathed filenames
'Must have nbfields% initialized as the number of fields
'Must have dbcont$(1 to nbfields%, 1 to nbrec%) initialized as record's string variable
   txtfname$ = Left$(dbfname$, Len(dbfname$) - 3) & "txt"
   ActiveWorkbook.Sheets("YourTargetSheet").Select
   Range("A1").Activate
   fh% = FreeFile
   Open txtfname$ For Output As #fh%
      For ptr% = 1 To nbrec%
          For ptr2% = 1 To nbfields% - 1
             dbcont$(ptr2%, ptr%) = ActiveCell.Offset(ptr% - 1, ptr2% - 1).Formula
             Print #fh%, dbcont$(ptr2%, ptr%) & ",";
          Next ptr2%
          dbcont$(ptr2%, ptr%) = ActiveCell.Offset(ptr% - 1, nbfields% - 1).Formula
          Print #fh%, dbcont$(nbfields%, ptr%)
       Next ptr%
    Close #fh%
End Sub

kilroy    Contents   

Public Sub LastCells_in_Sheet()

'Computes the last lower left used cell and the last lower right used cell
    str1$ = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Address
    str2$ = "$A$" & Right$(str1$, Len(str1$) - 3) 'str2$ is the last lower left used cell
    ActiveSheet.Range(str2$).Select
    str3$ = Right$(str1$, Len(str1$) - 5) 'str3$ is the last lower right used cell
End Sub

Public Function lng_LastRow()
   lng_LastRow = Range("A:Z").End(xlDown).Row
End Function

kilroy    Contents   

Public Sub FormatCellEuro()

'Formats a cell in Euros
   ActiveSheet.Range("b10").NumberFormat = "#,###,###.00"
End Sub

kilroy    Contents   

Public Sub AFLtoCOD()

'Converts an Ascii fixed length datafile to an Ascii Comma Delimited datafile
'Works with ReadNFO and FldExtract
'Must have NFO_Data, DAT_Data and COD_Data initialized as fullypathed filenames
'Must have nbflds% initialized as number of fields
'Must have fldlen%(1 to nbflds%) initialized as length of field
'Must have startat%(1 to nbflds%) initialized as 1st position of field in fixed length record
   If nfoflag = 0 Then ReadNFO
   If FileExists(COD_Data) Then
       MsgBox COD_Data & " exists."
   Else
       fh% = FreeFile
       Open DAT_Data For Input As #fh%
          Open COD_Data For Output As #fh% + 1
             While Not EOF(fh%)
                Input #fh, str1$
                For ptr% = 1 To nbflds% - 1
                    str2$ = Mid$(str1$, startat%(ptr%), fldlen%(ptr%))
                    Print #fh% + 1, FldExtract(str1$, ptr%, "R"), ",";
               Next ptr%
               str2$ = Mid$(str1$, startat%(ptr%), fldlen%(ptr%))
               Print #fh% + 1, FldExtract(str1$, ptr%, "R")
           Wend
      Close
   End If
End Sub

kilroy    Contents   

Sub CommonReadSub()

'This is my own cooking of the CommonReadSub Routine
'It works with all my Read_nnn Routines
'We start by setting the font to FixedSys avoiding the variable font width !
'We then save the XLS_Data file
'Then we name the table and the fields for further use
   'Setting the font to Fixedsys
   str1$ = "A:" + Chr$(Asc("A") + nbflds - 1)
   Columns(str1$).Select
   With Selection.Font
       .Name = "Fixedsys"
       .Size = 10
       .Strikethrough = False
       .Superscript = False
       .Subscript = False
       .OutlineFont = False
       .Shadow = False
       .Underline = xlUnderlineStyleNone
       .ColorIndex = xlAutomatic
          End With
   'Setting the columns width
   Range("A1").Activate
   For ptr2% = 1 To nbflds
      ActiveSheet.Columns(ptr2%).ColumnWidth = fldlen(ptr2%) + 5
   Next ptr2%
   'Create (save) XLS_Data
   ChDir [basepath]
   Application.DisplayAlerts = False
   ActiveWorkbook.SaveAs filename:=XLS_Data, _
         FileFormat:=xlNormal, _
         password:="", _
         writerespassword:="",_
         ReadOnlyRecommended:=False, _
         CreateBackup:=False
   thatWorkbook = [basename] & ".xls"
   Windows([thatWorkbook]).Activate
   sheetsname = Left(ActiveSheet.Name, 3)
   'Name the entire table as "AllTable" &sheetsname
   Selection.CurrentRegion.Select
   nbrows = Selection.Rows.Count
   nbcols = Selection.Columns.Count
   ActiveWorkbook.Names.Add Name:="AllTable"& sheetsname, RefersToR1C1:=Selection
   'Name each entire column as "AllCol" &ptr% & sheetsname
   Range("A1").Select
   ptr% = 1
   Do Until IsEmpty(Selection.Value)
       Range(ActiveCell, ActiveCell.Offset(nbrows - 1, 0)).Select
       ActiveWorkbook.Names.Add Name:="AllCol" & ptr% & sheetsname, RefersToR1C1:=Selection
            ptr% = ptr% + 1
      ActiveCell.Offset(0, 1).Select
   Loop
   'Name each datacolumn (= entire column less 1st row which may have title or fieldname) as "DataCol" & ptr% &sheetsname
   Range("A2").Select
   ptr% = 1
   Do Until IsEmpty(Selection.Value)
       Range(ActiveCell, ActiveCell.Offset(nbrows - 2, 0)).Select
       ActiveWorkbook.Names.AddName:="DataCol" & ptr% & sheetsname, RefersToR1C1:=Selection
       ptr% = ptr% + 1
       ActiveCell.Offset(0, 1).Select
    Loop
   'Name the entire datatable (=entire table less row1) as DataTable & sheetsname
   Range("A2", Range("A2").Offset(nbrows - 2, nbcols - 1)).Select
   ActiveWorkbook.Names.Add Name:="DataTable"& sheetsname, RefersToR1C1:=Selection
   'Setting the columns width
   Range("A1").Activate
   For ptr2% = 1 To nbflds
      ActiveSheet.Columns(ptr2%).ColumnWidth = fldlen(ptr2%) + 5
   Next ptr2%
   Range("A1").Select
   ActiveWorkbook.Save
   ActiveWorkbook.Close
   ThisWorkbook.Activate
   Range("A1").Select
   Application.ScreenUpdating = True
   Application.DisplayAlerts = False
End Sub

kilroy    Contents   

Public Function ChainCut(strin As String, sense As String, what As String)

'Cuts a chain (strin) upto or from (according to sense) a given character (what)
   'sense = "R" if right sense
   'sense = "L" if left sense
   If UCase(sense) = "R" Then
       ChainCut = Right$(strin, Len(strin) - InStr(strin, what))
   Else
       ChainCut = Left$(strin, InStr(strin, what) - 1)
   End If
End Function

kilroy    Contents   

Public Function FileExists(filename) As Boolean

'Returns true if file exists, false otherwise
   FileExists = (Dir(filename) <> "")
End Function

kilroy    Contents   

Public Function FldExtract(strin As String, ByVal fldidx As Integer, trimmer As String)

'Extracts a field from an ascii fixed length record (strin)
'fldidx% is the number of the field to extract
'trimmer is a Trim condition string = L, R, B, N for Left, Right, Both, None effect
'Must have nbflds% initialized as number of fields
'Must have fldlen%(1 to nbflds%) initialized as length of field
'Must have startat%(1 to nbflds%) initialized as 1st position of field in fixed length record
   Select Case UCase(trimmer)
       Case Is = "L"
          FldExtract = LTrim(Mid$(strin, startat%(fldidx%), fldlen%(fldidx%)))
       Case Is = "R"
          FldExtract = RTrim(Mid$(strin, startat%(fldidx%), fldlen%(fldidx%)))
       Case Is = "B"
          FldExtract = Trim(Mid$(strin, startat%(fldidx%), fldlen%(fldidx%)))
       Case Is = "N"
          FldExtract = Mid$(strin, startat%(fldidx%), fldlen%(fldidx%))
   End Select
End Function

kilroy    Contents   

Sub ReadAFL()

'This procedure reads a FIXED LENGTH ASCII data file whose extension is .dat
'Please note that .dat and .afl extensions cover exactly the same type of data files.
'where each record has been written without any separator
'each record being a sum of all fixed-length fields,
'terminated by a vbcrlf (chr$(13)+chr$(10)
'For comma delimited files, see the ReadCOD procedure
'Must have NFO_Data and AFL_Data initialized as fully pathed datafilename
'Works with CommonReadSub and ReadNFO which are found elsewhere
   If nfoflag = 0 Then ReadNFO
   If FileExists(AFL_Data) = False Then
       FileCopy DAT_Data, AFL_Data
   End If
   If FileExists(AFL_Data) = True Then
       Workbooks.OpenText _
         filename:=AFL_Data, _
         Origin:=xlWindows, _
         StartRow:=1, _
         DataType:=xlFixedWidth, _
         TextQualifier:=xlTextQualifierDoubleQuote, _
         ConsecutiveDelimiter:=False, _
         Tab:=False, _
         SemiColon:=False, _
         Comma:=False, _
         Space:=False, _
         Other:=False, _
         FieldInfo:=fldinf, _
         TextVisualLayout:=False
       CommonReadSub
    Else
       MsgBox AFL_Data & "file does not exist !!!", vbCritical, "ERROR ..."
   End If
End Sub

kilroy    Contents   

Sub ReadCOD()

'This procedure reads a Comma Delimited Ascii data file whose extension is .cod
'where each record has been written with a comma character between the fields
'each record being a concatenated chain of all fields,
'terminated by a vbcrlf (chr$(13)+chr$(10)
'For fixed length files, see the ReadAFL procedure
'Must have NFO_Data and AFL_Data initialized as fully pathed datafilename
'Works with AFLtoCOD (found elsewhere) if COD file does not exist
'Works with CommonReadSub and ReadNFO which are found elsewhere
   If nfoflag = 0 Then ReadNFO
   If FileExists(COD_Data) = False Then
       MsgBox COD_Data & " file does not exist !!!", vbCritical, "ERROR ..."
       str1$ = InputBox("<c>reate the file or <q>uit ...?", "What Shall I do ?", "")
      If UCase(str1$) = "C" Then
         AFLtoCOD
       Else
          Exit Sub
       End If
    End If
   Workbooks.OpenText _
      filename:=COD_Data, _
      Origin:=xlWindows, _
      StartRow:=1, _
      DataType:=xlDelimited, _
      TextQualifier:=xlTextQualifierDoubleQuote,_
      ConsecutiveDelimiter:=False,_
      Tab:=False, _
      SemiColon:=False, _
      Comma:=True, _
      Space:=False, _
      Other:=False
   CommonReadSub
End Sub

kilroy    Contents   

Sub ReadDAT()

'This procedure is similar to the ReadAFL routine
'...because AFL and DAT extensions cover the same type of datafiles
' GO AND SEE ReadAFL !!!
'Works with CommonReadSub and ReadNFO which are found elsewhere
   If nfoflag = 0 Then ReadNFO
   If FileExists(DAT_Data) = True Then
       Workbooks.OpenText _
         filename:=AFL_Data, _
         Origin:=xlWindows, _
         StartRow:=1, _
         DataType:=xlFixedWidth, _
          TextQualifier:=xlTextQualifierDoubleQuote, _
         ConsecutiveDelimiter:=False, _
         Tab:=False, _
         SemiColon:=False, _
         Comma:=False, _
         Space:=False, _
         Other:=False, _
         FieldInfo:=fldinf, _
         TextVisualLayout:=False
       CommonReadSub
   Else
      MsgBox DAT_Data & "file does not exist !!!", vbCritical, "ERROR ..."
   End If
End Sub

kilroy    Contents   

Sub ReadTAD()

'This procedure reads a Comma Delimited Ascii data file whose extension is .cod
'where each record has been written with a TAB character between the fields
'each record being a concatenated chain of all fields,
'terminated by a vbcrlf (chr$(13)+chr$(10)
'Must have NFO_Data and AFL_Data initialized as fully pathed datafilename
'Works with CommonReadSub and ReadNFO which are found elsewhere
   If nfoflag = 0 Then ReadNFO
   If FileExists(TAD_Data) = True Then
      Workbooks.OpenText _
       filename:=TAD_Data, _
       Origin:=xlWindows, _
       StartRow:=1, _
       DataType:=xlDelimited, _
       TextQualifier:=xlTextQualifierDoubleQuote, _
       ConsecutiveDelimiter:=False, _
       Tab:=True, _
       SemiColon:=False, _
       Comma:=False, _
       Space:=False, _
       Other:=False
       CommonReadSub
   Else
       MsgBox TAD_Data & " file does not exist !!!", vbCritical, "ERROR ..."
   End If
End Sub

kilroy    Contents   

Sub ReadSPD()

'This procedure reads a Space Delimited Ascii data file whose extension is .spd
'where each record has been written with a SPACE character between the fields
'each record being a concatenated chain of all fields,
'terminated by a vbcrlf (chr$(13)+chr$(10)
'Must have NFO_Data and AFL_Data initialized as fully pathed datafilename
'Works with CommonReadSub and ReadNFO which are found elsewhere
   If nfoflag = 0 Then ReadNFO
   If FileExists(SPD_Data) = True Then
      Workbooks.OpenText _
       filename:=SPD_Data, _
       Origin:=xlWindows, _
       StartRow:=1, _
       DataType:=xlDelimited, _
       TextQualifier:=xlTextQualifierDoubleQuote, _
       ConsecutiveDelimiter:=False, _
       Tab:=False, _
       SemiColon:=False, _
       Comma:=False, _
       Space:=True, _
       Other:=False
       CommonReadSub
   Else
       MsgBox SPD_Data & " file does not exist !!!", vbCritical, "ERROR ..."
   End If
End Sub

kilroy    Contents   

Sub ReadSCD()

'This procedure reads a Semi Colon Delimited Ascii data file whose extension is .scd
'where each record has been written with a SemiColon character between the fields
'each record being a concatenated chain of all fields,
'terminated by a vbcrlf (chr$(13)+chr$(10)
'Must have NFO_Data and AFL_Data initialized as fully pathed datafilename
'Works with CommonReadSub and ReadNFO which are found elsewhere
   If nfoflag = 0 Then ReadNFO
   If FileExists(SCD_Data) = True Then
      Workbooks.OpenText _
         filename:=SCD_Data, _
         Origin:=xlWindows, _
         StartRow:=1, _
         DataType:=xlDelimited, _
         TextQualifier:=xlTextQualifierDoubleQuote, _
         ConsecutiveDelimiter:=False, _
         Tab:=False, _
         SemiColon:=True, _
         Comma:=False, _
         Space:=False, _
         Other:=False
      CommonReadSub
   Else
       MsgBox SCD_Data & " file does not exist !!!", vbCritical, "ERROR ..."
   End If
End Sub

kilroy    Contents   

Sub ReadXLS()

'This procedure reads an XLS worksheet
'Must have namflag% initialized when the filenames NFO_Data and XLS_Data have been initialized
'Works with ReadNFO
   If namflag = False Then ReadNFO
   Workbooks.Open filename:=XLS_Data, ReadOnly:=True
End Sub

kilroy    Contents   

Sub CopyRangeToRange(srcrange as String, destrange as String)

'This procedure copies the cells from srcrange to the cells of destrange in the worksheet
   Range(srcrange).Copy Destination:=Range(destrange)
End Sub

kilroy    Contents   

Sub PrintSheet()

'This procedure prints the active worksheet to the printer
   ActiveSheet.PrintOut
End Sub

kilroy    Contents   

About Coloring Cells Backgrounds and/or Cells Texts
             Making fonts Bold and/or Underlining the fonts
 Setting Borders anywhere around a Cell

As an example, we'll compute the last cells of the Active Sheet
and calculate the sum of columns B and C

   'Here we go finding the last cells with our routine GetRealCells found in this Cookbook
   GetRealLastCells
   'so, we know reallastrow and reallastcol

   'let us put the formulas for the sums at end of columns B and C
   Range("B" & reallastrow + 1).Formula = "=sum(B1:B" & reallastrow & ")"
   Range("C" & reallastrow + 1).Formula = "=sum(C1:C" & reallastrow & ")"
   'Now we will select the two sums
   Range("B" & reallastrow + 1 & ":C" & reallastrow + 1).Select
   With Selection
                 'and, for the selection,
      .Font.Color = vbRed
   'set the text in Red : use vbBlue, vbYellow, vbGreen ... to change
      .Font.Bold = True
        'make the font Bold : False would unbold !
   End With
   'Put a thick border around the selection
   ActiveSheet.Range("B" & reallastrow + 1 & ":C" & reallastrow + 1).BorderAround ColorIndex:=1, Weight:=xlThick

kilroy    Contents   

Color of the text in Cell(s)

See my snippet of code at Coloring Text, Cells, Ranges in a WorkSheet


kilroy    Contents   

Bold Text in Cell(s)

See my snippet of code at Coloring Text, Cells, Ranges in a WorkSheet


kilroy    Contents   

Unbold Text in Cell(s)

See my snippet of code at Coloring Text, Cells, Ranges in a WorkSheet
And change the existing code

        'make the font Bold
      .Font.Bold = True
To
        'unmake Bold
      .Font.Bold = False

kilroy    Contents   

Underline Text in Cell(s)

See my snippet of code at Coloring Text, Cells, Ranges in a WorkSheet


kilroy    Contents   

Putting Border(s) around Cell(s)

See my snippet of code at Coloring Text, Cells, Ranges in a WorkSheet


kilroy    Contents   

Sub WriteToLogFile(strin As String)

'This procedure writes some text (strin) to the log file c:\ExcelLog.txt
   'ref E2KVBAP72
   Dim ReturnValue
   ReturnValue = Shell("NOTEPAD.EXE c:\ExcelLog.txt", vbNormalFocus)
   AppActivate ReturnValue
   Application.SendKeys strin, True
   Application.SendKeys "%FE~", True
   Application.SendKeys "%FQ~", True
End Sub

kilroy    Contents   

Sub ClearImmediateWindow()

'This procedure clears the immediate window
   'ref E2KVBAP72
   Application.VBE.Windows.Item("Immediate").SetFocus
   Application.SendKeys "^a"
   Application.SendKeys "{Del}"
End Sub

kilroy    Contents   

Sub ShowOnStatusBar()

'This procedure puts some text on the status bar
   'ref E2KVBAP71
   Dim i As Long
   For i = 0 To 1000000
      If i Mod 1000000 = 0 Then
          Application.StatusBar = "Processing record " & i
      End If
   Next i
   Application.StatusBar = False
End Sub

kilroy    Contents   

Sub AddAWorkbook()

'This procedure adds(creates) a new workbook
   'ref E2KVBAP79
   Dim wkb1 As Workbook
   set wkb1 = workbooks.add
   wkb1.Activate
End Sub

kilroy    Contents   

Function GetFileNameFromPath(stfullname As String) As String

'This Function Gets the filename from a full path
   'ref E2KVBAP80
   Dim stpathsep As String
   Dim fnamelen As Integer
   Dim i As Integer
   stpathsep = Application.pathseparator
   fnamelen = Len(stfullname)
   For i = fnamelen To 1 Step -1
      If Mid(stfullname, 1, 1) = stpathsep Then Exit For
   Next i
   GetFileNameFromPath = Right(stfullname, fnamelen - 1)
End Function

kilroy    Contents   

'This procedure Copies a worksheet sheettocopy to snewsheetname
'ref E2KVBA
Sub CreateNewWorkSheet(sheettocopy As String, snewsheetname As String)
   Dim icount As Integer
   Dim wks As Worksheet
   icount = Worksheets.Count
   Worksheets(sheettocopy).Copy after:=Worksheets(icount)
   icount = icount + 1
   Set wks = Worksheets(icount)
   wks.Name = snewsheetname
End Sub

kilroy    Contents   

'This procedure Gets the real last cells of a worksheet
Sub GetReallastCells()
   'in the general section of the module
   Public reallastrow As Long
   Public reallastcol As Long
   'end of general section

   reallastrow = 0
   reallastcol = 0

   Range("A1").Select

   On Error Resume Next

   reallastrow = Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
   reallastcol = Cells.Find("*", Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column

   Cells(reallastrow, reallastcol).Activate
   'on return of this routine, reallastrow = last row
   'reallastcol = last column
End Sub

Public Function lng_LastRow()
   lng_LastRow = Range("A:Z").End(xlDown).Row
End Function

kilroy    Contents   

'This procedure Removes the Numbers BUT NOT THE FORMULAS from a given range of a worksheet
   'ref E2KVBAP106
Sub RemoveNumbersNotFormulas()
   On Error Resume Next
   Cells.SpecialCells(xlCellTypeConstants, xlNumbers).ClearContents
End Sub

kilroy    Contents   

'This procedure Sums up a given range of a worksheet
   'ref E2KVBAP109
Sub SumARange()
   With ActiveCell
       Set rng = Range(.Offset(1), .Offset(1).End(xlDown)).Formula = "SUM(" & rng.Address & ")"
   End With
End Sub

kilroy    Contents   

About Using Arrays and Ranges

As an example, we'll compute the last cells of the Active Sheet
and put data in an array and see how to use it

   'Here we go finding the last cells
   'With the procedure GetRealCells found in this Cookbook
   GetRealLastCells
   'Now, we know the reallastrow and reallastcol

   'Due to headers in row 1, data is located in range A2 to D & reallastrow
   'Let's put data in an array
   data_array = Range("A2:D" & reallastrow).Value
   'To retrieve any data from the array, use   'searched_data=data_array(searched_row_nr-1,searched_column_nr)

   'Example: data_array(11,3) will be the content of Cell("C10")

kilroy    Contents   

'In the module, at the declaration level
Option Explicit
Declare Function GetSystemMetrics Lib "user32" _
      (ByVal nIndex As Long) As Long
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
'END of module level

Function VIDEO(dimension)
   Select Case UCase(dimension)
   Case "HEIGHT"
      VIDEO = GetSystemMetrics(SM_CYSCREEN)
   Case "WIDTH"
      VIDEO = GetSystemMetrics(SM_CXSCREEN)
   Case Else
      VIDEO = CVErr(xlErrNA)
   End Select
End Function

kilroy    Contents   

Public Function CELLTYPE(cell)

'Returns the cell type of the upper left cell in a range
   Dim UpperLeft As Range
   Application.Volatile
   Set UpperLeft = cell.Range("A1")
   Select Case True
      Case UpperLeft.NumberFormat = "@"
         CELLTYPE = "Text"
      Case IsEmpty(UpperLeft)
         CELLTYPE = "Blank"
      Case WorksheetFunction.IsText(UpperLeft)
         CELLTYPE = "Text"
      Case WorksheetFunction.IsErr(UpperLeft)
         CELLTYPE = "Error"
      Case WorksheetFunction.IsLogical(UpperLeft)
         CELLTYPE = "Logical"
      Case IsDate(UpperLeft)
         CELLTYPE = "Date"
      Case InStr(1, UpperLeft.Text, ":") <> 0
         CELLTYPE = "Time"
      Case IsNumeric(UpperLeft)
         CELLTYPE = "Value"
   End Select
End Function

kilroy    Contents   

Public Function LASTINROW(rng As Range) As Variant
   Dim WorkRange As Range
   Dim i As Integer, CellCount As Integer
   Application.Volatile
   Set WorkRange = rng.Rows(1).EntireRow
   Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
   CellCount = WorkRange.Count
   For i = CellCount To 1 Step -1
      If Not IsEmpty(WorkRange(i)) Then
         LASTINROW = WorkRange(i).Value
         Exit Function
      End If
   Next i
End Function

Public Function lng_LastRow()
   lng_LastRow = Range("A:Z").End(xlDown).Row
End Function

kilroy    Contents   

Public Function LASTINCOLUMN(rng As Range) As Variant
   Dim WorkRange As Range
   Dim i As Integer, CellCount As Integer
   Application.Volatile
   Set WorkRange = rng.Columns(1).EntireColumn
   Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
   CellCount = WorkRange.Count
   For i = CellCount To 1 Step -1
      If Not IsEmpty(WorkRange(i)) Then
         LASTINCOLUMN = WorkRange(i).Value
         Exit Function
      End If
   Next i
End Function

Public Function lng_LastRow()
   lng_LastRow = Range("A:Z").End(xlDown).Row
End Function

kilroy    Contents   

Public Function CELLHASFORMULA(cell) As Boolean

'Returns TRUE if cell has a formula
   CELLHASFORMULA = cell.Range("A1").HasFormula
End Function

kilroy    Contents   

Public Function CELLFORMULA(cell) As String

'Returns the formula in cell, or an empty string if cell has no formula
   Dim UpperLeft As Range
   Set UpperLeft = cell.Range("A1")
   If UpperLeft.HasFormula Then
      CELLFORMULA = UpperLeft.Formula
   Else
      CELLFORMULA = ""
   End If
End Function

kilroy    Contents   

Public Function CELLISHIDDEN(cell) As Boolean

'Returns TRUE if cell is hidden
   Dim UpperLeft As Range
   Set UpperLeft = cell.Range("A1")
   If UpperLeft.EntireRow.Hidden Or UpperLeft.EntireColumn.Hidden Then
      CELLISHIDDEN = True
   Else
      CELLISHIDDEN = False
   End If
End Function

kilroy    Contents   

Public Function ISBOLD(cell) As Boolean

   'Returns TRUE if cell is bold
   ISBOLD = cell.Range("A1").Font.Bold
End Function

kilroy    Contents   

Public Function ISITALIC(cell) As Boolean

   'Returns TRUE if cell is italic
   ISITALIC = cell.Range("A1").Font.Italic
End Function

kilroy    Contents   

Public Function ALLBOLD(cell) As Boolean

   'Returns TRUE if all characters in cell are bold
   Dim UpperLeft As Range
   Dim i As Integer
   Set UpperLeft = cell.Range("A1")
   ALLBOLD = True
   For i = 1 To UpperLeft.Characters.Count
      If Not UpperLeft.Characters(i).Font.Bold Then
         ALLBOLD = False
         Exit Function
      End If
   Next i
End Function

kilroy    Contents   

Public Function FILLCOLOR(cell) As Integer

   'Returns an integer corresponding to cell's interior color
   FILLCOLOR = cell.Range("A1").Interior.ColorIndex
End Function

kilroy    Contents   

Public Function REVERSETEXT(text) As String

   'Returns its argument, reversed
   Dim TextLen As Integer
   Dim i As Integer
   TextLen = Len(text)
   For i = TextLen To 1 Step -1
      REVERSETEXT = REVERSETEXT & Mid(text, i, 1)
   Next i
End Function

kilroy    Contents   

Public Function SCRAMBLE(text)

   'Scrambles its single-cell argument
   Dim TextLen As Integer
   Dim i As Integer
   Dim RandPos As Integer
   Dim Char As String * 1
   Set text = text.Range("A1")
   TextLen = Len(text)
   For i = 1 To TextLen
      Char = Mid(text, i, 1)
      RandPos = Int((TextLen - 1 + 1) * Rnd + 1)
      Mid(text, i, 1) = Mid(text, RandPos, 1)
      Mid(text, RandPos, 1) = Char
   Next i
   SCRAMBLE = text
End Function

kilroy    Contents   

Public Function ACRONYM(text) As String

   'Returns an acronym for text
   Dim TextLen As Integer
   Dim i as Integer
   text = Application.Trim(text)
   TextLen = Len(text)
   ACRONYM = Left(text, 1)
   For i = 2 To TextLen
      If Mid(text, i, 1) = Chr(32) Then
          ACRONYM = ACRONYM & Mid(text, i + 1, 1)
      End If
   Next i
   ACRONYM = UCase(ACRONYM)
End Function

kilroy    Contents   

Public Function ISLIKE(text As String, pattern As String) As Boolean

   'Returns true if the first argument is like the second
   If text Like pattern Then ISLIKE = True Else ISLIKE = False
End Function

kilroy    Contents   

Function CellHasText(cell) As Boolean

    'Returns TRUE if cell contains a string or cell is formatted as Text
   Dim UpperLeft As Range

   CELLHASTEXT = False
   Set UpperLeft = Cell.Range("A1")
   If UpperLeft.NumberFormat = "@" Then
      CELLHASTEXT = True
      Exit Function
   End If
   If Not IsNumeric(UpperLeft) Then
      CELLHASTEXT = True
      Exit Function
   End If
End Function

kilroy    Contents   

Function ExtractElement(Txt, n, Separator) As String

   'Returns the nth element of a text string, where the
   ' elements are separated by a specified separator character
   Dim Txt1, TempElement As String
   Dim ElementCount, i As Integer

   Txt1 = Txt
   ' If space separator, remove excess spaces
   If Separator = Chr(32) Then Txt1 = Application.Trim(Txt1)
   ' Add a separator to the end of the string
    If Right(Txt1, Len(Txt1)) <> Separator Then Txt1 = Txt1 & Separator
   'Initialize
   ElementCount = 0
   TempElement = ""
   'Extract each element
   For i = 1 To Len(Txt1)
      If Mid(Txt1, i, 1) = Separator Then
         ElementCount = ElementCount + 1
         If ElementCount = n Then
             ' Found it, so exit
             EXTRACTELEMENT = TempElement
             Exit Function
         Else
             TempElement = ""
         End If
      Else
          TempElement = TempElement & Mid(Txt1, i, 1)
      End If
   Next i
   EXTRACTELEMENT = ""
End Function

kilroy    Contents   

'Naming fields

   'Find the real cell using a routine posted somewhere else
   GetRealLastCells
   'Selecting the Sheet
   ActiveWorkbook.Sheets("sheet_where_to_apply").Select
   'Selecting the Range
   Range("B1:B" & reallastrow).Select
   'Naming the Range which is here one column (b) starting at row (a)
   ActiveWorkbook.Names.Add Name:="new_desired_name", RefersToR1C1:= _
      "=ListGen!RaCb:R" & reallastrow & "Cb"
   Range("A1").Select

'Yet another way to name ranges
   'for the sake of clarity, we have replaced:
   '      your_sheet_name by ysn
   '      your_desired_name by ydn
   '      starting_column_letter by scl
   '      starting_row_number by srn
   '      ending_column_letter by ecl
   '      ending_row_number by ern
   'If you want to create a global name
   Names.Add Name:="ysn!ydn", RefersTo:="$scl$srn:$ecl$ern"
   '.........But you might also use:
   Range("sclsrn:eclern").Name = "ydn"
   'If you want to create a local name
   Names.Add Name:="ysn!ydn", RefersTo:="ysn!$scl$srn:$ecl$ern"
   '.........But you might also use:
   Range("sclsrn:eclern").Name = "ysn!ydn"

kilroy    Contents   

'UsingArrayFormulas
   Sheets("BalGen").Select
   GetRealLastCells

   'put formula for Débit in row1 column D=4
   Range("D1").Activate
   Selection.FormulaArray = _
      "=SUM((ctesgendebit)*((ctesgenno)=(BalGen!$B1)))"
   'copy to full range
   Range("D1").Select
   Application.CutCopyMode = False
   Selection.Copy
   Range("D2:D" & reallastrow).Select
   ActiveSheet.Paste
   Application.CutCopyMode = False
   'put formula for Credit in row1 column E=5
   Range("E1").Activate
   Selection.FormulaArray = _
      "=SUM((ctesgencredit)*((ctesgenno)=(BalGen!$B1)))"
   'copy to full range
   Range("E1").Select
   Application.CutCopyMode = False
   Selection.Copy
   Range("E2:E" & reallastrow).Select
   ActiveSheet.Paste
   Application.CutCopyMode = False

kilroy    Contents   

'CopyingFormulas

   'put formulas in row1
   Sheets("CtesCli").Select
   Range("C1").Activate
   Selection.Formula = _
      "=INDEX(ListCli!$B$1:$B$" & nbcli% & ",A1,0)"
   'copy to full range
   Selection.Copy
   Range("C2:C" & erf%).Select
   ActiveSheet.Paste
   Application.CutCopyMode = False
   Range("A1").Activate
'Copying Array Formulas
   'put formula for Credit in row1 column E=5
   Range("E4").Activate
   Selection.FormulaArray = _
      "=SUM((balgencredit)*((balgennocte)=($C4)))"
   'copy to full range
   Range("E4").Select
   Application.CutCopyMode = False
   Selection.Copy
   '1st block = 4 to 106 and 4 is done !
   Range("E5:E106").Select
   ActiveSheet.Paste
   '2nd block = 109 to 214
   Range("E109:E214").Select
   ActiveSheet.Paste
   Application.CutCopyMode = False

kilroy    Contents   

'Writing Formulas
   Sheets("any_wanted_sheet").Select
   Range("any_suitable_cell").Activate
   Selection.Formula = _
      "=INDEX(ListCli!$B$1:$B$" & nbcli% & ",A1,0)"
'Writing Array Formulas
   Sheets("any_wanted_sheet").Select
   Range("any_suitable_cell").Activate
   Selection.FormulaArray = _
      "=SUM((balgencredit)*((balgennocte)=($C4)))"

kilroy    Contents   

Public Sub AssignRangeToArray()

'Assign a Range to an Array
      'Arrays are variants : lets dim a variant
      Dim tdebit As Variant
      'Select the desired sheet in the open workbook
      Sheets("BalGen").Select
      'Compute last Cells
      GetRealLastCells
      'Array must be the whole table
       tdebit = Range("A1:" & Chr$(Asc(reallastcol) + 64) & reallastrow).Value
End Sub

kilroy    Contents   

'Retrieve the value of Row = ridx, Column = cidx in Array = arrin
Public Function RetrieveArrVal(arrin As Variant, ridx As Long, cidx As Long) As Double
      ArrVal = arrin(ridx, cidx)
End Function

kilroy    Contents   

Sub CopyAndAutoFilter()

   'Here's how to: - Copy a whole worksheet at the end of the workbook
   '..........................- Apply an AutoFilter on that copy
   'We need an integer
   Dim icount As Integer
   'set icount = nr of worksheets in the workbook
   icount = Worksheets.Count
   'copy it at the end of the workbook
   Sheets("your_desired_sheet").Select
   'select the desired sheet
   Sheets("your_desired_sheet").Copy After:=Worksheets(icount)
   'need to know last column
   GetRealLastCells
   'we must add a header line (row)
   Range("A1").Select : Selection.EntireRow.Insert
   'now we must put the header in each column
   For icount = 1 To reallastcol : ActiveCell.Offset(0, icount - 1) = "Col" & icount : Next icount
   'we want headers in bold letters
    Range("A1:" & Chr$(reallastcol + 65) & "1").Select : Selection.Font.Bold = True
   'and a bottom edge border
   With Selection.Borders(xlEdgeBottom)
         .LineStyle = xlContinuous
         .Weight = xlThin
         .ColorIndex = xlAutomatic
   End With
   'now we will action the autofilter
   Range("A1").Select : Selection.AutoFilter
End Sub

kilroy    Contents   

Public Function GetValue(path, file, sheet, ref)

   'Retrieves a value from a closed workbook
   Dim arg As String
   'Make sure the file exists
   If Right(path, 1) <> "\" Then path = path & "\"
   If Dir(path & file) = "" Then
      GetValue = "File Not Found"
      Exit Function
   End If
   'Create the argument
   arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
      Range(ref).Range("A1").Address(,, xlR1C1)
   ' Execute an XLM macro
   GetValue = ExecuteExcel4Macro(arg)
End Function
   ' LOOK AT THE 2 EXAMPLES BELOW !

Getting the Value of one Cell out of a closed Workbook ... and ... Getting the Value of a range of Cells out of a closed Workbook


Public Sub TestGetOneCellValue()
   Dim p, f, s, a, srcRow, srcCol, destRow, destCol
   p = "c:\Mes documents\xlworks\xltxt"
   f = "OneFormulaReport.xls"
   s = "Report"
   Application.ScreenUpdating = False

   'Fix source Row and Column to B4
   srcRow = 4: srcCol = 2
   'Put in variable a
   a = Cells(srcRow, srcCol).Address
   'Fix destination Row and destination Column to A1
   destRow = 1: destCol = 1
   'Getit !
   Cells(destRow, destCol) = GetValue(p, f, s, a)
   Application.ScreenUpdating = True
End Sub

Public Sub TestGetRangeValue()
   Dim p, f, s, a, r, c
   p = "c:\Mes documents\xlworks\xltxt"
   f = "OneFormulaReport.xls"
   s = "Report"
   Application.ScreenUpdating = False

   'Here range is from A1 to H21
   For r = 1 To 21
      For c = 1 To 8
         a = Cells(r, c).Address
         Cells(r, c) = GetValue(p, f, s, a)
      Next c
   Next r
   Application.ScreenUpdating = True
End Sub

kilroy    Contents   

Sub ResetAllSheetsToA1()

   ' Resets all the sheets of a workbook to A1
   Dim i
   For i = 1 To Sheets.Count
      Sheets(i).Select
      Range("A1").Select
      Sheets(1).Select
   Next i
End Sub

kilroy    Contents   

Function COUNTBETWEEN(rng, num1, num2)

   'Counts number of values between num1 and num2
   Dim CellCount As Integer
   Dim cell As Range
   Set rng = Intersect(rng.Parent.UsedRange, rng)
   CellCount = 0
   For Each cell In rng
       If cell.Value >= num1 And cell.Value <= num2 Then CellCount = CellCount + 1
   Next cell
   COUNTBETWEEN = CellCount
End Function

kilroy    Contents   

Function SUMVISIBLE(rng)

   ' Sums only visible cells
   Dim CellSum As Long
   Dim cell As Range
   Application.Volatile
   CellSum = 0
   Set rng = Intersect(rng.Parent.UsedRange, rng)
   For Each cell In rng
      If IsNumeric(cell) Then
          If Not cell.EntireRow.Hidden _
And Not cell.EntireColumn.Hidden Then CellSum = CellSum + cell
      End If
   Next cell
   SUMVISIBLE = CellSum
End Function

kilroy    Contents   

Function NEXTMONDAY(d As Date) As Date
   Dim TestDay As Date
   TestDay = d + 1
   Do Until WeekDay(TestDay) = 2
      TestDay = TestDay + 1
   Loop
   NEXTMONDAY = TestDay
End Function

kilroy    Contents   

Function NEXTDAY(d As Date, day As Integer) As Variant

   ' Returns the next specified day
   Dim TestDay As Date
   'Make sure day is between 1 and 7
   If day < 1 Or day > 7 Then
      NEXTDAY = CVErr(xlErrNA)
      Exit Function
   End If
   TestDay = d + 1
   Do Until WeekDay(TestDay) = day
      TestDay = TestDay + 1
   Loop
   NEXTDAY = TestDay
End Function

kilroy    Contents   

Function MONTHWEEK(d As Date) As Integer

   'Returns the week of the month for a date
   Dim FirstDay As Integer
   'Check for valid date argument
   If Not IsDate(d) Then
      MONTHWEEK = CVErr(xlErrNA)
      Exit Function
   End If
   ' Get first day of the month
   FirstDay = WeekDay(DateSerial(Year(d), Month(d), 1))
   ' Calculate the week number
   MONTHWEEK = Application.RoundUp((FirstDay + day(d) - 1) / 7, 0)
End Function

kilroy    Contents   

   'at the module level
Option Explicit Private Declare Function GetDriveType32 Lib "kernel32" _
   Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings _
   Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal _
       nBufferLength As Long,ByVal lpBuffer As String) As Long
   'end of module level

Function DRIVEEXISTS(DriveLetter As String) As Boolean
   ' Returns True if a specified drive letter exists
   Dim Buffer As String * 255
   Dim BuffLen As Long
   Dim DLetter As String * 1
   Dim i As Integer
   DLetter = Left(DriveLetter, 1)
   BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
   DRIVEEXISTS = False
   'Search for the string
   For i = 1 To BuffLen
      If Ucase(Mid(Buffer, i, 1)) = Ucase(DLetter) Then
          'Found it
         DRIVEEXISTS = True
         Exit Function
      End If
   Next i
End Function

kilroy    Contents   

   'at the module level
Option Explicit Private Declare Function GetDriveType32 Lib "kernel32" _
   Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings _
   Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal _
      nBufferLength As Long, ByVal lpBuffer As String) As Long
   'end of module level

Function DRIVETYPE(DriveLetter As String) As String
   ' Returns a string that describes the drive type
   Dim DLetter As String * 2
   Dim DriveCode As Integer

   DLetter = Left(DriveLetter, 1) & ":"
   DriveCode = GetDriveType32(DLetter)

   Select Case DriveCode
      Case 1: DRIVETYPE = "Local"
      Case 2: DRIVETYPE = "Removable"
      Case 3: DRIVETYPE = "Fixed"
      Case 4: DRIVETYPE = "Remote"
      Case 5: DRIVETYPE = "CD-ROM"
      Case 6: DRIVETYPE = "RAM Disk"
      Case Else: DRIVETYPE = "Unknown Drive Type"
   End Select
End Function

kilroy    Contents   

Function COUNTVISIBLE(rng)

   ' Counts visible cells
   Dim CellCount As Long
   Dim cell As Range
   Application.Volatile
   CellCount = 0
   Set rng = Intersect(rng.Parent.UsedRange, rng)
   For Each cell In rng
      If Not IsEmpty(cell) Then
         If Not cell.EntireRow.Hidden And _
             Not cell.EntireColumn.Hidden Then _
             CellCount = CellCount + 1
      End If
   Next cell
   COUNTVISIBLE = CellCount
End Function

kilroy    Contents   

Function MAXALLSHEETS(cell)
   Dim MaxVal As Double
   Dim Addr As String
   Dim Wksht As Object
   Application.Volatile
   Addr = cell.Range("A1").Address
   MaxVal = -9.9E+307
   For Each Wksht In cell.Parent.Parent.Worksheets
      If Wksht.Name = cell.Parent.Name And _
         Addr = Application.Caller.Address Then

                      'avoid circular reference
      Else
         If IsNumeric(Wksht.Range(Addr)) Then
             If Wksht.Range(Addr) > MaxVal Then MaxVal = Wksht.Range(Addr).Value
         End If
   Next Wksht
   If MaxVal = -9.9E+307 Then MaxVal = 0
   MAXALLSHEETS = MaxVal
End Function

kilroy    Contents   

Function SHEETOFFSET(offset, Ref)

   'Returns cell contents at Ref, in sheet offset
   'REQUIRES FUNCTION SHEETOFFSET found elsewhere
   Dim WksIndex As Integer
   Application.Volatile
   WksIndex = WorksheetIndex(Application.Caller.Parent)
   SHEETOFFSET = Worksheets(WksIndex + offset).Range(Ref.Address)
End Function

kilroy    Contents   

Public Function WorksheetIndex(x As Worksheet) As Integer

   ' Returns the Worksheets (not Sheets) Index
   Dim Wks As Worksheet, WksNum As Integer
   WksNum = 1
   For Each Wks In x.Parent.Worksheets
      If x.Name = Wks.Name Then
         WorksheetIndex = WksNum
         Exit Function
      End If
      WksNum = WksNum + 1
   Next Wks
End Function

kilroy    Contents   

Public Function MYSUM(ParamArray n() As Variant) As Variant

   ' Emulates Excel's SUM function
   Dim i As Integer
   Dim TmpRng As Range
   Dim cell As Range
   Dim ErrCode As String
   MYSUM = 0
   ' Process each iument
   For i = 0 To UBound(n)
      ' Skip missing iuments
      If Not IsMissing(n(i)) Then
         ' What type of argument is it?
         Select Case TypeName(n(i))
             Case "Range"
                'Create temp range to handle full row/column args
                Set TmpRng = Intersect(n(i).Parent.UsedRange, n(i))
                   For Each cell In TmpRng
                      If Application.IsError(cell) Then
                         ErrCode = CStr(cell)
                          MYSUM = CVErr(Right(ErrCode, Len(ErrCode), InStr(ErrCode, " ")))
                          Exit Function
                      End If
                      If cell = True Or cell = False Then
                         MYSUM = MYSUM + 0
                      Else
                          If IsNumeric(cell) Then MYSUM = MYSUM + cell
                      End If
                   Next cell
             Case "Error"
                'return the error
                MYSUM = n(i)
                Exit Function
            Case Else
                ' Check for literal TRUE and compensate
                If n(i) = "True" Then MYSUM = MYSUM + 2
                MYSUM = MYSUM + n(i)
         End Select
      End If
   Next i
End Function

kilroy    Contents   

Public Function RANDOMINTEGERS()
   Dim FuncRange As Range
   Dim V() As Variant, ValArray() As Variant
   Dim CellCount As Double
   Dim i As Integer, j As Integer
   Dim r As Integer, c As Integer
   Dim Temp1 As Variant, Temp2 As Variant
   Dim RCount As Integer, CCount As Integer
   Randomize

   'Create Range object
   Set FuncRange = Application.Caller
   ' Return an error if FuncRange is too large
   CellCount = FuncRange.Count
   If CellCount > 1000 Then
      RANDOMINTEGERS = CVErr(xlErrNA)
      Exit Function
   End If
   'Assign variables
   RCount = FuncRange.Rows.Count
   CCount = FuncRange.Columns.Count
   ReDim V(1 To RCount, 1 To CCount)
   ReDim ValArray(1 To 2, 1 To CellCount)
   ' Fill array with random numbers
   ' and consecutive integers
   For i = 1 To CellCount
      ValArray(1, i) = Rnd
      ValArray(2, i) = i
   Next i
   ' Sort ValArray by the random number dimension
   For i = 1 To CellCount
      For j = i + 1 To CellCount
          If ValArray(1, i) > ValArray(1, j) Then
             Temp1 = ValArray(1, j)
             Temp2 = ValArray(2, j)
             ValArray(1, j) = ValArray(1, i)
             ValArray(2, j) = ValArray(2, i)
             ValArray(1, i) = Temp1
             ValArray(2, i) = Temp2
         End If
      Next j
   Next i
   ' Put the randomized values into the V array
   i = 0
   For r = 1 To RCount
      For c = 1 To CCount
         i = i + 1
         V(r, c) = ValArray(2, i)
      Next c
   Next r
   RANDOMINTEGERS = V
End Function

kilroy    Contents   

Function SHEETNAME() As String

   'Returns the sheet name of the cell that contains the function
   SHEETNAME = Application.Caller.Parent.Name
End Function

kilroy    Contents   

Function WORKBOOKNAME() As String

   ' Returns the workbook name of the cell that contains the function
   WORKBOOKNAME = Application.Caller.Parent.Parent.Name
End Function

kilroy    Contents   

Function APPNAME() As String

   ' Returns the application name of the cell that contains the function
   APPNAME = Application.Caller.Parent.Parent.Parent.Name
End Function

kilroy    Contents   

Function EXCELVERSION() As Variant

   ' Returns Excel's version number
   EXCELVERSION = Application.Version
End Function

kilroy    Contents   

You can create your own headers and footers:
       ActiveSheet.Pagesetup.Leftfooter = "my left footer"

       ActiveSheet.Pagesetup.Centerfooter = ActiveWorkbook.Name
       ActiveSheet.Pagesetup.Rightfooter = ActiveSheet.Name

       ActiveSheet.Pagesetup.Leftheader = "my left footer"

       ActiveSheet.Pagesetup.Centerheader = ActiveWorkbook.Name
       ActiveSheet.Pagesetup.Rightheader = ActiveSheet.Name

kilroy    Contents   

Public Sub SaveAll()

   'This macro will save all of the workbooks open in Excel.
   Dim WB As Workbook
   For Each WB In Workbooks
      WB.Save
   Next WB
   Application.StatusBar = "All Workbooks Saved."
End Sub

kilroy    Contents   

'Here's how to call the function :
      'ExShToNewWbk srcwbk, deswbk, srcwsh

'And here are the contents of your calling parameters:
      'srcwbk = "name_of_your_source_workbook"
      'deswbk = "name_of_your_destination_workbook"
      'srcwsh = "name_of_your_source_worksheet"

Public Sub ExShToNewWbk(ByVal srcwbk As String, ByVal deswbk As String, ByVal srcwsh As String)
   'We are now anywhere in the source workbook (srcwbk): Add (=create) a new workbook
   Workbooks.Add
   'We are now anywhere in the destination workbook (deswbk): Back to srcwbk
   Windows(srcwbk).Activate
   'Copy srcwsh to deswbk
   Sheets(srcwsh).Copy Before:=Workbooks(deswbk).Sheets(1)
   'Save deswbk as deswbk (this will give deswbk a name !)
   ActiveWorkbook.SaveAs FileName:=deswbk & ".xls", FileFormat:= _
         xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
         , CreateBackup:=True
   'We are nom in the new workbook deswbk
'The copy was made as a true copy : srcwsh exists BOTH in deswbk and in srcwbk
'Changing False to true in the last code sentence would erase srcwsh from srcwbk
End Sub

kilroy    Contents   

Using Excel's built-in Functions

'Here is how to use Excel build-in Functions in VBA Code:
       'afficher coursor
       frm_Prix.txt_coursor.Value = _
             Format(Application.WorksheetFunction.Round(Worksheets("Paramètres").Range("E2").Value, 2), _
             "€ #####.00")

kilroy    Contents   

List all Named Ranges in a New WorkSheet of the WorkBook
Public Sub ShowNames()

   'if there are no Names in the ActiveWorkBook
   If ActiveWorkbook.Names.Count = 0 Then
      'Tell it to the user
      MsgBox "There are no names in the active workbook " & ActiveWorkbook.Name
   Else
      'Add a New WorkSheet to the WorkBook
      Sheets.Add

      'Rename the newly added WorkSheet to "The Named Ranges"
      ActiveWorkbook.ActiveSheet.Name = "The Named Ranges"

      'Set headers row = 1 col = A
      ActiveCell.Offset(0, 0).Formula = "The ActiveWorkbook Name = "
      ActiveCell.Offset(0, 1).Formula = ActiveWorkbook.Name

      'Set Headers...
      Range("A1:B1").Select
         '........Bold and Navy
         With Selection.Font
            .Bold = True
            .Name = "Arial"
            .Size = 14
            .ColorIndex = 11
         End With

      'Set Names for Sub-Headers A3 + B3 + C3
      Range("A3").Select
      ActiveCell.FormulaR1C1 = "Name"
      Range("B3").Select
      ActiveCell.FormulaR1C1 = "Sheet"
      Range("C3").Select
      ActiveCell.FormulaR1C1 = "Range"

      'Set Sub-Headers A3 to C3
      Range("A3:C3").Select
      '.........Bold
      Selection.Font.Bold = True
      '.........Bottom Border
      With Selection.Borders(xlEdgeBottom)
         .LineStyle = xlContinuous
      End With

      'Set Columns Widths
      Columns("A:A").ColumnWidth = 41
      Columns("B:B").ColumnWidth = 20
      Columns("C:C").ColumnWidth = 24

      'Change font Selection for the Sheet
      '...so as to put more text in it !
      Range("A4:C219").Select
      With Selection.Font
         .Name = "Arial"
         .Size = 8
      End With

      'point to Cell A1
      Range("A1").Select

      'Define some variables
      Dim Names As String, NameItem As Variant, ptr As Integer

      'Initialise (row) offset to 4 (= row 5)
      ptr = 4

      'Loop through all ActiveWorkBook's Names
      For Each NameItem In ActiveWorkbook.Names
         'Send Name of named range to Sheet's ActiveCell.Offset Column A
         ActiveCell.Offset(ptr, 0).Formula = NameItem.Name
         'Send Sheet where the named range to Sheet's ActiveCell.Offset Column B
            ActiveCell.Offset(ptr, 1).Formula = NameItem.RefersToRange.Parent.Name
         'Send named range range's address to Sheet's ActiveCell.Offset Column C
         ActiveCell.Offset(ptr, 2).Formula = NameItem.RefersToRange.Address
         'Bump (row) offset ptr
         ptr = ptr + 1
      Next NameItem

   End If
End Sub

kilroy    Contents   

FIND A MATCHING ELEMENT IN A LIST
Public Sub ChercherClient()
   Dim searchme As String
   Dim searchedrow As Double

   'must select sheet to pick up reallastcells
   Worksheets("Clients").Select
   'pick up reallastcells
   GetReallastCells

   'CHECK IF worksheet ListCli exists
   'Here, we use the Function SheetExists found somewhere else in this document.
   If SheetExists("ListCli") = 0 Then
      'ListCli does not exist, must create a new worksheet
      Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
      'must name the new worksheet as ListCli
      Worksheets(Worksheets.Count).Name = "ListCli"
   End If

   'must copy all names from column C of worksheet Clients
   Worksheets("Clients").Select
   Range("C1").Activate
   For ptr = 1 To reallastrow
      tint1 = InStr(ActiveCell.Offset(ptr - 1, 0).Text, " ")
      If tint1 > 0 Then
          Worksheets("ListCli").Range("A" & ptr).Formula = UCase(Left(ActiveCell.Offset(ptr - 1, 0).Text, tint1 - 1))
      Else
          Worksheets("ListCli").Range("A" & ptr).Formula = UCase(ActiveCell.Offset(ptr - 1, 0).Text)
      End If
   Next ptr

   'the match for clients will be found in column C of worksheet Clients
   'but searched in column A of worksheet ListCli

   'get the searchme string
   searchme = UCase(InputBox("Nom...:", "Recherche d'un Elément", ""))
   'find its row as searchedrow
   On Error GoTo CliMatchError
   searchedrow = Application.WorksheetFunction.Match(searchme, Worksheets("ListCli").Range("A1:A" & reallastrow), 0)
   'select it
   ActiveSheet.Range("C" & searchedrow).Select
   Exit Sub

CliMatchError:
   MsgBox "Le Client " &
      searchme & " n'existe pas !!!" & _
      vbCrLf & vbCrLf & _
      "Recommencez la recherche...", vbCritical, "Erreur..."
      On Error GoTo 0
End Sub

kilroy    Contents   

Compute the VAT

   'We have declared here dblaTaux, dblaBase, dblaTTC, fTva and fHtva
   'so as to avoid confusion with existing program variables

$1. Compute VAT (fTVA) on the Base (dblaBase)
Public Function fTVA(dblaBase As Double, dblaTaux As Double) As Double
   'the dblaTaux MUST be a percentage as in 0.21
   fTVA = WorksheetFunction.Round(dblaBase * dblaTaux, 2)
End Function

$2. Compute HTVA on the TTC (dblaTTC)
Public Function fHTVA(dblaTTC As Double, dblaTaux As Double) As Double
   'the dblaTaux MUST be a percentage as in 0.21
   dblaTaux = dblaTaux * 100
   fHTVA = WorksheetFunction.Round(dblaTTC - (dblaTTC / (100 + dblaTaux) * dblaTaux), 2)
End Function

kilroy    Contents   

Check if a given Sheet Exists
Public Function SheetExists(shtname As String) As Integer
   SheetExists = 0
   tint2 = ActiveWorkbook.Worksheets.Count
   For ptr2 = 1 To tint2
      If Worksheets(ptr2).Name = shtname Then
         SheetExists = 1
         Exit Function
      End If
   Next ptr2
End Function

kilroy    Contents   

  CONTACTS !

E-mail

Phone

Fax

Street Address

affordsol@skynet.be

intl +32.67.340.350

intl +32.67.340.351

Affordable Solutions

Rue du Nouveau Monde, 48

     

B-7060 - SOIGNIES

     

Belgium

kilroy  by    Affordable Solutions