Archive for the ‘VBA Code Library’ Category.
I had a worksheet table with blank rows separating the groups.
I needed to add another column - a formula - but wanted to retain the blank rows for formatting tidiness.
The table after adding the formula column:
Notice the formula produces zeros for the blank rows. I could just select each cell (D3, D5, D8, D10) and hit delete, but for thousands of rows that would be time consuming.
Here's how I did it:
- Select column C.
- From the Edit menu, select Go To..., then click Special...
- Select Blanks, then click OK
Then I ran a macro which allows me to move the selection over one column.
In this example, I typed 0, 1 for the Input to SelectionOffset.
After the Selection was moved, I hit the delete key.
Sub SelectionOffset()
Dim strInput As String, str As String, i As Long, bln As Boolean
Dim strRows As String, strCols As String
strInput = ""
Do
bln = False
strInput = InputBox("Selection offset by rows, cols" & vbNewLine & _
"eg. 12, 2", "Selection offset", strInput)
str = Replace(strInput, " ", "")
If str <> "" Then
i = InStr(str, ",")
If i = 0 Then strRows = str Else strRows = IIf(i = 1, "0", Left(str, i - 1))
If i = 0 Or i = Len(str) Then strCols = "0" Else strCols = Mid(str, i + 1)
If IsNumeric(strRows) And IsNumeric(strCols) Then
On Error Resume Next
Selection.Offset(strRows, strCols).Select
If Err.Number <> 0 Then
MsgBox "Invalid selection offset", vbExclamation, "Error"
bln = True
End If
On Error GoTo 0
Else
MsgBox "Selection offset is not numeric", vbExclamation, "Error"
bln = True
End If
End If
Loop While bln
End Sub
Here is one for the Code Library.
Somehow I end up misplacing this bit of code. So every time I need to do it, I end up re-writing it.
Perhaps I'll save someone the same frustration along the way.
This code snippet will loop through each file in your folder (and subfolders).
For each workbook opened, it will unprotect each worksheet using the supplied password.
Const cStartFolder = "D:\MySecretSpreadsheets" 'no slash at end
Const cFileFilter = "*.xls"
Const cPassword = "trustno1"
Sub UnprotectAllWorksheets()
Dim i As Long, j As Long, arr() As String, wkb As Workbook, wks As Worksheet
ExtractFolder cStartFolder, arr()
On Error Resume Next
j = -1: j = UBound(arr)
On Error GoTo 0
For i = 0 To j
Set wkb = Workbooks.Open(arr(i), False)
For Each wks In wkb.Worksheets
wks.Unprotect cPassword
Next
wkb.Save
wkb.Close
Next
End Sub
Sub ExtractFolder(Folder As String, arr() As String)
Dim i As Long, objFS As Object, objFolder As Object, obj As Object
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(Folder)
For Each obj In objFolder.SubFolders
ExtractFolder obj.Path, arr()
Next
For Each obj In objFolder.Files
If obj.Name Like cFileFilter Then
On Error Resume Next
i = 0: i = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(i)
arr(i) = objFolder.Path & Application.PathSeparator & obj.Name
End If
Next
End Sub
From time to time, I am asked to audit a spreadsheet.
One of the common mistakes I see is an inconsistent formula inside a group of cells.
For example:
- A1 has the formula =G1 * 0.105
- A1 has been formula auto-filled to A1:E5
- Then some time later, cell A3 has been changed to =G3 * 0.107
So the assumption is that A1 can be safely auto-filled to the region of cells. However, we have an exception which should be noted.
It's nice to be able to highlight these exceptions. Here are 2 ways.
1. If you have Excel XP and above, you can use the Error Checking options. A little green triangle appears telling you that "something strange" is going on.
One downfall of the Error Checker is that it wont trigger if the inconsistent formula is on the corner of the checked region. In our example above, if the changed formulas was A5 instead of A3, it would have ignored that inconsistency.
I assume that this is to accommodate subtotals and grand totals?
2. Write a bit of VB code using the idea that the R1C1 version of the formula should be identical for all cells in the selection, so it should be a simple loop to check all of the formulas.
Here is an example:
Sub test()
Dim strFormula As String, rng As Range
strFormula = Selection(1).FormulaR1C1
For Each rng In Selection
If rng.FormulaR1C1 <> strFormula Then rng.Interior.ColorIndex = 6
Next
End Sub
To use it, select the range A1:E5 then run the macro. It would colour the inconsistent formulas yellow (in the first example, cell A3).
This article describes a bug recently discovered by Ron de Bruin and which has also
been reported here.
The Application.InputBox function is very useful to get a range from
the user. Unfortunately, this function exposes a bug in Excel (all current
versions!). If the sheet on which a (range of) cell(s) is selected contains
conditional formatting using the : "Formula Is" option, the function may fail,
returning an empty range.
The only reliable workaround is to build a userform to request the range from
the user, which I have included as a download here.
I have an array of user defined types. The type has three elements and I need to sort on all three. Surprisingly, I've never had to sort an array of udt's before. Here's how I did it:
Type MyInfo
lType As Long
sName As String
dStart As Date
End Type
Sub Start()
Dim aInfo(0 To 4) As MyInfo
Dim i As Long
Dim vaTypes As Variant
Dim vaNames As Variant
Dim vaDates As Variant
'fill the array with some unsorted data
vaTypes = Array(2, 1, 1, 2, 1)
vaNames = Array("Joe", "Bob", "Bob", "Joe", "Joe")
vaDates = Array(#1/1/2006#, #2/1/2006#, #1/15/2006#, #6/30/2005#, #1/8/2006#)
For i = 0 To 4
aInfo(i).lType = vaTypes(i)
aInfo(i).sName = vaNames(i)
aInfo(i).dStart = vaDates(i)
Next i
'call the sort procedure
SortInfo aInfo
'output the results to the immediate window
For i = LBound(aInfo) To UBound(aInfo)
Debug.Print aInfo(i).lType, aInfo(i).sName, aInfo(i).dStart
Next i
End Sub
Sub SortInfo(ByRef aInfo() As MyInfo)
Dim i As Long, j As Long
Dim tTemp As MyInfo
'standard bubble sort loops
For i = LBound(aInfo) To UBound(aInfo) - 1
For j = i To UBound(aInfo)
'sort on the first element
If aInfo(i).lType> aInfo(j).lType Then
SwapInfo aInfo, i, j
'if the first element is the same, sort on the second
ElseIf aInfo(i).lType = aInfo(j).lType And _
aInfo(i).sName> aInfo(j).sName Then
SwapInfo aInfo, i, j
'if the first two elements are the same, sort on the third
ElseIf aInfo(i).lType = aInfo(j).lType And _
aInfo(i).sName = aInfo(j).sName And _
aInfo(i).dStart> aInfo(j).dStart Then
SwapInfo aInfo, i, j
End If
Next j
Next i
End Sub
Sub SwapInfo(ByRef aInfo() As MyInfo, ByVal lOne As Long, ByVal lTwo As Long)
Dim tTemp As MyInfo
tTemp = aInfo(lOne)
aInfo(lOne) = aInfo(lTwo)
aInfo(lTwo) = tTemp
End Sub
Is there an easier way?
Sometimes I need to analyse data (row-by-row) in a worksheet with a lot of columns. Sometimes I then want to see information from a cell in a column way off to the far right together with a couple of columns on the left side of the sheet. Of course you can split the window, freeze the panes, but this isn't always sufficient.
I devised a tiny utility that shows a modeless window (only works in XL2000 and up) which displays the content of a cell in a set column on the same row:
The form can be resized to get it out of the way and accomodate for the amount of information you want to see.
Find it here.