Find and placing elements in a long string/column of text - vba

The following is the result of downloading information from an accounting system. Basically, I was tasked with sorting through expenses from this year from an online system; once the information was downloaded from the online system, it was not formatted as a spreadsheet (so I couldn't easily use a simple lookup). The information was downloaded as a spreadsheet, however it didn't contain check numbers or names; excel formatted those away for some reason. The only thing that was left is the long stringy document, where each item in the PDF downloaded (which contained check numbers and names) was placed in column 1 (see picture 1), whereas it should have been placed in something formatted like picture 2. Obviously though PDF's do not maintain formatting.
So baring some way that I can transfer the PDF to a workbook and run an analysis (IE through copy paste or save as) I needed to get information from this long stringy thing (it's at 9000 rows at the moment, added in an excerpt).
First, this code sets the worksheet pers as a worksheet, gets the length of data in pers (example in picture 2), and length of data in expensesheet (example in picture 1)
Then it scans pers for items (prior to writing this code items were added manually - such as in the case of picture 2, 'supply 1' and corresponding information that can help denote supply 1, ie invoice #, description, date cut, and so on).
For each of those items, it then scans the "expense sheet". It tries to match the invoice number (which is the closest thing to a unique ID in this case) to the value in cell i, 1; if it exists, it then scans 'upwards' until it finds a long enough string so that it can be the 5 unit string; the one that contains a date, a check number, an amount, and a name, as well as a batch number and a memo.
Once it finds that string, it then splits it into an array, and then seeks to place it in the corresponding cells to the right of that row in worksheet pers.
Issues:
1) I keep receiving an error 400. Normally when I receive an error VBA shows what line. What is this? How can I set up an error catching block so that the editor will provide me more details on the error (ie place it occurred, reason for occurrence, etc)
2) I'm assuming that the long row (in this case its 12th from the top) can only be identified through its length. Is there a better way to identify the long row? Perhaps if it contains multiple dashes?
3) Does anyone know of a way to easily transfer a PDF of an accounting printout so that it retains its formatting when saved or copied to a spreadsheet?
4) Is there a way that this spreadsheet could be easily formatted through excel so that it can more adequately fit into the proper mold (more like picture 2)?
Option Explicit
Sub findDetailMemo()
Dim pers As Worksheet
Set pers = ThisWorkbook.Sheets("PERS")
Dim persLength As Long
persLength = pers.Range("a1").End(xlDown).Row
Dim expenseLength As Long
expenseLength = Range("a1").End(xlDown).Row
Dim currentDetail() As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim tempInt As Long
'first scan all of the items in the pers unit
For k = 2 To 10
'next scan all of the expenses
For i = 2 To expenseLength
'if the invoice # is found
If InStr(Cells(i, 1), pers.Range("a1").Offset(k, 3)) <> 0 Then
'scan upwards; make sure you don't scan beyond the range of the spreadsheet
For j = i To 1 Step -1
'if the scan upwards finds a string that is 80 characters or more
If Len(Cells(i - j, 1)) >= 80 Then
'split it at the -
currentDetail = Split(Cells(i - j, 1), "-", -1, vbTextCompare)
'add it to the pers sheet
pers.Range("a1").Offset(k, 11) = currentDetail(0)
pers.Range("a1").Offset(k, 12) = currentDetail(1)
pers.Range("a1").Offset(k, 13) = currentDetail(2)
pers.Range("a1").Offset(k, 14) = currentDetail(3)
Exit For
End If
Next j
Exit For
Else
End If
Next i
Next k
End Sub

EDIT: After a discussion through the chat lobby, bdpolinsky and I found what was throwing the original error 400 (which was actually error 1004).
The first issue we fixed was the InStr() and Split() functions were referencing Cell objects instead of the string within them. This was fixed by simply adding Cells().Text where strings were required.
On the line If Len(Cells(i - j, 1).Text) >= 80, we discovered that Cells() wasn't referencing the correct worksheet. The fix for this was to define Cells() as pers.Cells(), which is the worksheet the information was imported to. Happy to report that the problem bdpolinsky was having has been solved (as far as the errors go).
The following is from the original answer:
1) At the start of your code (first executable line) you can press F8 to step through the code 1 line at a time until the error is flagged.
You can also use error handlers to catch an error and have excel do something different than default. Error Handling
Sub SomeCode()
Dim i As Integer
On Error GoTo ErrHandler
i = 1/0
ErrHandler:
MsgBox "Error Description: " & Err.Description
End Sub
You can also click next to a line of code to add a Break. Breaks look like red circles, and color that line of code red. Your code will stop when it reaches this line.
2)If Len(cellThatYoureChecking) > 20 Then Code
Or
If InStr(cellThatYoureChecking, "symbolYouWantToFind") <> 0 Then Code
Or visit this post about defining how many times a character is in a string with a function. You could then make your If statement based on the number of times it occurs.
3) This part is poor form for StackOverflow, but what you're asking is a little involved so see if this tutorial is of use to you. Import table from PDF to Excel.
4) The short answer to this is yes. There are a lot of ways to reorganize data in Excel. This question is a little too broad though, and it'd be more efficient to get questions 1-3 answered first before getting too ahead of ourselves.

Related

Issue using Instr with Cell Formats

I have a puzzle that i've trying to solve for some time. I have a spreadsheet that imports data from a .csv file, which worls well apart from the intial location setting.
I currently run a search to find the last cell that contains a value and use that as the starting point. Now for reason above and beyond me this sometimes fails and places the starting point halfway down the spreadsheet. SO to get around this I decided to write a check code or a more sophisticated location finder.
The new Location finder is as follows
For a = 1 To 400
Dim SearchString As Variant
Dim SearchSymbol As String
SearchString = Cells(NewLastRowNumber, 10)
SearchSymbol = "€"
If InStr(1, SearchString, SearchSymbol, 1) = 0 Then
NewLastRowNumber = NewLastRowNumber - 1
Else
NewLastRowNumber = NewLastRowNumber + 1
Exit For
End If
Next a
This works, apart from the what it searches within the cell. The ideal behind is it search a column of data containing cost, i.e (Row 1 -> €100, Row 2 -> €235 etc..) and find the last cell containng € currently I can only ever get it to find the column header and not the cell.
Each cell in the column is formatted as a Custom (€0.00), not sure if this makes any difference or not.
Ive embeded some images to further demonstrate my issue.
At this point NewLastRowNumber = 13
At this point the loop should break and record NewLastRowNumber = 13 but instead it continues until it finds the column header.
Hope this all makes sense & thanks.
The cell is formatted as Currency or Custom, thus you cannot find the Euro sign there. When you check InStr(), it checks the cell .Value, not the .Format.
To find the Eur in the Cell, check the format like this:
If Cells(NewLastRowNumber, 10).NumberFormat = "€0.00" Then
To see the exact number format in VBA, select the cell with the wanted format and run the following:
Sub Test()
Debug.Print Selection.NumberFormat
End Sub

Find specific cells, change value of adjacent cell, value depends on location (Excel for Mac, 15.6)

this is my first post here, I know I'm articulating this poorly.
I'm trying to find cells containing a specific phrase in a column of dates. This phrase marks the beginning of a section. I then want to state the number of days elapsed from the first date in each section to other dates in the section. The values returned should show up in the adjacent column. Below is an example of the columns.
Dates and Elapsed number of days in adjacent column
I use this formula in the 2nd column:
=A15-$A$15
And then drag this down to cells in the relevant section. I'm trying to automate this process.
I found this code on this site and changed it a little bit to get this:
For Each cCell In Range("A1,A900")
cCell.Select
If ActiveCell.Value = "Phrase" Then
ActiveCell.Offset(1, 1).Value = "-"
End If
Next cCell
So my struggle is what to say in the 2nd Value field. I somehow need to get each section to subtract the first date of each section (the date right under "Phrase").
Another challenge is to copy that first adjacent cell that was changed, and then paste special into the cells below, but stopping once the next "Phrase" appears.
I'll elaborate any way I can. Thanks.
I think it's fair to say your question doesn't show much effort at solving this problem and the code snippet simply places a dash next to a "Phrase" cell. However, for a wider audience the question is interesting because it highlights the difference between automating an Excel keystroke task and writing code to process data which is then written in an Excel worksheet. Both use VBA but the former is simply a programmatic record of keystrokes and the latter is an algorithmic solution.
The telling phrase in your question is: I use this formula in the 2nd column ... and then drag this down to cells in the relevant section. I'm trying to automate this process. It would be possible to do this by using VBA to reproduce a bunch of worksheet functions but it's fiddly and could become complicated. I'll leave someone else to answer that as they'd need to spend more time on the answer than you have on the question (one of my don't do rules!).
If, on the other hand, you step away from trying to automate keystrokes and towards VBA for data processing, the problem becomes very trivial. It's a really good example of how VBA, in just a few lines, can solve problems that Excel functions might take pages to do, and probably not reliably.
So here's the code as a VBA solution. It'll need some data checking lines added to deal with blank cells, non-dates, etc. but I'll hand that task back to you:
Dim ws As Worksheet
Dim firstCell As Range
Dim lastCell As Range
Dim dataCells As Range
Dim v As Variant
Dim output() As Variant
Dim r As Long
Dim refDate As Long
'Define the range to be worked
Set ws = ThisWorkbook.Worksheets("Sheet1") 'amend as required
Set firstCell = ws.Range("A1") 'amend as required
Set lastCell = ws.Cells(ws.Rows.Count, "A").End(xlUp) 'amend as required
Set dataCells = ws.Range(firstCell, lastCell)
'Read the values and size the output array
v = dataCells.Value2 'use Value2 to avoid date format issues
ReDim output(1 To UBound(v, 1), 1 To 1)
'Loop through the values, resetting the reference date on each "Phrase"
For r = 1 To UBound(v, 1)
If v(r, 1) = "Phrase" Then
output(r, 1) = "-"
refDate = v(r + 1, 1)
Else
output(r, 1) = v(r, 1) - refDate
End If
Next
'Write output into next column
dataCells.Offset(, 1).Value = output

Condense largely(Unpractical) loop based VBA code; nested For...Next loops

Hello everyone alright let start by giving some brief background on my project then I will follow up with my specific issue and code.
Currently I am building a program to automate the process of filling a template. This template exceeds 60,000 rows of data quite often and I've built the large majority of it to work month to month by plugging in new data sheets and running it. Currently all of the work is based off of one data sheet which I import into excel manually. This data sheet does not contain all the data I need to populate the template so now I am beginning to bring in additional data to supplement this. The problem herein lies with data association. When I was originally pulling from one data sheet I didn't have to worry if the data I pulled for each row coincided with the other rows because it all came from the same sheet. Now I have to cross check data across two sheets to confirm it is pulling the correct information.
Now for what you need to know. I am trying to fill a column that will be referred to as Haircut, but before I do that I need to confirm that I am pulling the correct haircut number in correlation to a Trade ID which was already populated into the template in a previous line of code.
Using similar logic that I have been using throughout my entire project this is a snippet of code I have to perform this task.
Dim anvil as Worksheet
Dim ALLCs as worksheet
Dim DS as worksheet
'''''''''''''''''''''''''''''code above this line is irrelevant to answer this question
ElseIf InStr(1, DS.Cells(x, 2), "Haircut") Then
Anvil.Select
For y = 1 To 80
If Anvil.Cells(1, y) = "Haircut" Then
For Z = 1 To 80
If Anvil.Cells(1, Z) = "Trade ID" Then
For t = 2 To 70000
For u = 16 To 70000
If Anvil.Cells(t, Z) = ALLCs.Cells(u, 34) Then
ALLCs.Cells(u, 27) = Anvil.Cells(t, y)
End If
Next
Next
End If
Next
End If
Next
This code coupled with my other code I assume will in theory work, but I can only imagine that it will take an unbelievable amount of time(this program already takes 7 and a half minutes to run). Any suggestions on how to rewrite this code with better functionality, following this general logic?
Any help is appreciated, whether you completely revamp the code, or if you offer suggestions on how to cut down loops. I am also looking for suggestions to speed up the code in general aside from screen updating and calculation suggestions.
If I understand the logic correctly then you can replace all but one of the loops with a .Find() method like so:
'// Dimension range objects for use
Dim hdHaricut As Excel.Range
Dim hdTradeID As Excel.Range
Dim foundRng As Excel.Range
With Anvil
With .Range("A1:A80") '// Range containing headers
'// Find the cell within the above range that contains a certain string, if it exists set the Range variable to be that cell.
Set hdHaircut = .Find(What:="Haircut", LookAt:=xlWhole)
Set hdTradeID = .Find(What:="Trade ID", LookAt:=xlWhole)
End With
'// Only if BOTH of the above range objects were found, will the following block be executed.
If Not hdHaricut Is Nothing And Not hdTradeID Is Nothing Then
For t = 2 To 70000
'// Using the .Column property of the hdTradeID range, we can see if the value of Cells(t, hdTradeColumn) exists
'// in the other sheet by using another .Find() method.
Set foundRng = ALLCs.Range(ALLCs.Cells(16, 34), ALLCs.Cells(70000, 34)).Find(What:=.Cells(t, hdTradeID.Column).Value, LookAt:=xlWhole)
'// If it exists, then pass that value to another cell on the same row
If Not foundRng Is Nothing Then ALLCs.Cells(foundRng.Row, 27).Value = .Cells(t, hdHaircut.Column).Value
'// Clear the foundRng variable from memory to ensure it isn't mistaken for a match in the next iteration.
Set foundRng = Nothing
Next
End If
End With

VBA: Invalid Next Control Variable Reference

Basically, i'm trying to mimic a concatenate result using code i stripped apart and recycled for my purposes. But i'm having problems when the script attempts to process "Next T" idk, but i already indicated as a Dim - Integer, and that still didnt seem to do the trick.
Original source of code:
Concatenate multiple ranges using vba
I've been having a lot of problems with this one piece, cause it seems to be the only thing i've actually been trying to include in my script for a long time now. Had compile errors with closing the If, adjusting the Then, and even Exiting the loop.
I think the Next should be my final worries.
Btw, rnumbers is supposed to hold the place of a value/integer, but i'm not entirely sure if that was done correctly either.
rnumbers = Rows(ActiveCell.Range("A3").End(xlDown)) + 3
'or CellCount = ActiveCell.Range("A" & Rows.Count).End(xldown).Row
Do While Rows(ActiveCell.Range("A3").End(xlDown)) > 3
'For Q = 1 To 10 'This provides a column reference to concatenate - Outer For statement
For T = 3 To rnumbers 'This provides a rows reference to concatenate - Inner for statement
For Each Cell In Cells("A" & T) 'provides rows and column reference
If Cell.Value = "" Then
GoTo Line1 'this tells the macro to continue until a blank cell is reached
Exit For
End If
x = x & Cell.Value & Chr(10) 'This provides the concatenated cell value and comma separator
'Next ' this loops the range
Next T 'This is the inner loop which dynamically changes the number of rows to loop until a blank cell is reached
Line1:
On Error GoTo Terminate 'Terminates if there are less columns (max 10) to concatenate
ActiveCell.Value = Mid(x, 1, Len(x) - 1) 'This basically removes the last comma from the last concatenated cell e.g. you might get for a range 2,3,4, << this formula removes the last comma to
'give 2,3,4
ActiveCell.Offset(1, 0).Select 'Once the concatenated result is pasted into the cell this moves down to the next cell, e.g. from F1 to F2
x = "" 'The all important, clears x value after finishing concatenation for a range before moving on to another column and range
'Next Q 'After one range is done the second column loop kicks in to tell the macro to move to the next column and begin concatenation range again
'rnumbers = 0
'Next
Exit Do
'Resume
Terminate:'error handler
Trying again... when I took a closer look at your code I actually used a Bad Word.
You have been hanging with the wrong crowd, and are picking up some really bad code structure ideas. A GoTo followed by an Exit For? The latter statement can never be reached! And jumping out of a For loop is a dangerous (if not wrong) thing to do. And yes, you still needed a Next for the For Each statement (with a matching control argument - the Next T belonged with a different For loop, not the innermost one).
Anyway - I felt like the Cat In The Hat: "This mess is so big and so deep and so tall - we cannot pick it up, there is No Way At All!". So I decided to build you a new house instead.
I think the following does what you want to do, and quite elegantly. See if it makes sense, and if you can adapt it for your purpose. I need to go to sleep but will take a look in the morning to see if you figured it out from here.
Sub concAll()
Dim allRows As Range, target as range
Dim oneRow
Dim nc as Integer
Set allRows = Range("A3", "J10") ' pick the real range here - dynamically, probably
nc = allRows.Columns.Count ' need this number later to know where to put result
For Each oneRow In allRows.Rows ' loop over one row of the range at a time
Dim s As String
s = "" ' start with empty string
For Each c In oneRow.Cells ' loop over all the cells in the row
If Not IsEmpty(c) Then
s = s & "," & c.Text
Else
Exit For ' done with this row: found empty cell
End If
Next c ' keep looping over the cells...
Set target = oneRow.Cells(1).Offset(0, oneRow.Cells.Count) ' cell where we put result
target.Value = Mid(s, 2) ' put the concatenated value to the right of everything;
' skipping first comma (which came before first text)
Next oneRow ' repeat for all rows in source range
End Sub
I'm sorry, i shouldve explained what i was trying to produce than asking to fix something i wanted to do. My experience in vba has been self-taught, and i'm a little new to asking for help.
The script Floris produced seemed to have function but not as intended. Turns out what i wrote is a little outdated, and needs to be wiped and restarted. This was actually an old script i started a few months back that worked off of a web-query. But the website went thru some changes and now the script is all over the place.
the main issue i was having was a compile-error "Invalid Next Control Variable Reference" Which turns out to be caused by an open 'Do while' loop, that doesnt seem to have much of an exit point from the research i looked up. Was supposed to have used another 'If' command instead. At the same time, when attempting to solve that 'Do While' i added an extra 'Next' (cause i thought they were compatible), and it screwed with the script.
Hard to explain.. But the 'Do While' i used, i wanted it to combine the values only if the number of values were greater
rnumbers = Rows(ActiveCell.Range("A3").End(xlDown)) + 3
'or CellCount = ActiveCell.Range("A" & Rows.Count).End(xldown).Row
Do While Rows(ActiveCell.Range("A3").End(xlDown)) > 3
But instead it was supposed to be
Dim CellCount As Range
CellCount = ActiveCell.Range("A" & Rows.Count).End(xlDown).Row + 2
'cause its the active cell + two additional cells
If CellCount > 3
Which then opens up into the script Floris submitted. (But that failed too, because of what was stated above).
Thanks again, hope that it explains everything... Sorry if i wasted your time with that one Floris, really do appreciate the assistance. Just wish i had asked for the help sooner, would have saved me a lot of frustration that i'm dealing with now. >_>

Find Worksheet Name and Row Number for an Excel Workbook

I am working with a workbook that contains three worksheets of data. Each worksheet has a Contract Number column. Certain contracts must be excluded and noted in a separate worksheet.
I would like to create Excel VBA macro that:
Prompts the user to enter specific contract numbers to be excluded
Stores contract numbers
Searches all three worksheets' contract column for the contract numbers
Notes the unwanted contract details in a "summary" worksheet, which has already been created
Deletes the unwanted contract row entirely
The macro should loop through this process below for 'n' number of contracts entered by the user.
Public contString As String
Public x As Variant
Public xCount As Variant
Sub find()
contString = InputBox(Prompt:="Enter contract numbers to exclude(Comma Delimited). Cancel to include all contracts.", _
Title:="Exclude Contracts", Default:="1715478")
x = Split(contString, ",")
xCount = UBound(x) 'Number of contracts entered by user
End Sub
Sub SearchWS1()
Sheets("WS1").Activate
Columns("I:I").Select 'Contract Number Column
Selection.find(What:=x(i), After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
BKWS = ActiveCell.Worksheet.Name
BKRow = ActiveCell.Row
If BKRow > 0 Then
Cname = Range("G" & BKRow)
Cnumber = Range("I" & BKRow)
Cvalue = Range("K" & BKRow)
'Summarize Excluded Contract Info on Summary WS
Range("Summary!B25").Value = "Exclusions:"
Range("Summary!B26").Value = Cnumber
Range("Summary!C26").Value = Cname
Range("Summary!D26").Value = Cvalue
'Select and Delete Contract
Rows(ActiveCell.Row).Select
Rows(BKRow).EntireRow.Delete
Else
Call SearchWS2 'SearchWS2 is essentially the same as SearchWS1 and Calls SearchWS3 if contract isn't found.
End If
End Sub
If the contract number doesn't exist in the first WS, I get an error like 'Object variable or With block not set'. Once I can fix this error, I will need to run this process through a loop for each contract number entered by the user. Any help with debugging the error or setting up a loop for this would be greatly appreciated.
Thanks!
Use the InputBox for inputting contract numbers (let's say, comma delimited). Split the result using Split function.
Store contract numbers on a separate worksheet that you hide (wks.visible=xlVeryHidden, where wks is a worksheet object).
Find values using a multidimensional array to store the values.
Print 2D array to found worksheet using rFound=saArray (where rFound is a range object and saArray is the 2D array.
Make heavy use of recording macros to learn syntax.
See this example on fast ways to retrieve and print to cells.
Update:
Sorry, this is pretty sloppy but I just threw it together and, obviously, it hasn't been tested. Hope this helps. Sorry, I also shouldn't be having you use advanced techniques like this, but it's hard for me to go back.
dim j as integer, k as integer, m as long, iContractColumn as integer
Dim x() as string, saResults() as string
dim vData as variant
dim wks(0 to 2) as worksheet
iContractColumn=????
set wks(0) = Worksheets("First")
set wks(1) = Worksheets("Second")
set wks(2) = Worksheets("Third")
redim saresults(1 to 100, 1 to 2)
m=0
'Loop thru worksheets
for j=0 to 2
'Get data from worksheet
vdata=wks(j).range(wks(j) _
.cells(1,iContractColumn),wks(j).cells(rows.count,iContractColumn).end(xlup))
'Loop through data
for k=1 to ubound(vdata)
'Loop through user criteria
For i = 0 To UBound(x)
'Compare user criteria to data
if x(i)=cstr(vdata(k,1)) then
'Capture the row and worksheet name
m=m+1
'If array is too small increase size
if m>ubound(saresults) then
redim preserve saresults(1 to ubound(saresults)*2, 1 to 2)
end if
'Get name and row.
saresults(m,1)=wks(j).name
saresults(m, 2)=k
exit for
end if
next i
next k
next j
'Resize array to correct size
redim preserve saresults(1 to m, 1 to 2)
'Print results to a result page (you could also create hyperlinks here
'that would make it so the person can click and go to the respective page.
'You would have to do a loop for each result on the range.
with worksheets("Result Page")
.range(.cells(1,1),.cells(m,2))=saresults
end with
I have little to add Jon49's answer which does seem to cover the basics. But I wish I had discovered Forms earlier in my VBA programming career. They can be a little confusing at first but, once mastered, they add enormously to the usability of a macro for very little effort.
Forms can be used to get values from the user (instead of InputBox) or can be used to give progress information to the user. I will only talk about the second usage. Your macro might take some time; has the user time to get a cup of coffee or will it finish in 5 seconds? I HATE programs that sit there saying "please wait - this may take from a few minutes to a few hours".
The following code loads a form into memory, shows it to the user and removes it from memory at the end. If you do not unload the form, it remains on the screen after the macro has ended which may be useful if you want to leave a message for the user. This form is show "modeless" which means the macro displays it and carries on. If shown "modal", the macro stops until the user has entered whatever information the form requires.
Load frmProgress
Progress.Show vbModeless
' Main code of macro
Unload frmProgress
There are no end to the web sites offering tutorials on Forms so I will mainly describe the what rather than how.
Within the VB Editor, Insert a UserForm. Drags the bottom and right edges if you want it bigger. Use the Properties Window to change the Name to frmProgress.
Drag four labels from the Tool Box and arrange them in a line. Set the caption of label 1 to "Worksheet " and the caption of label 3 to "of". Name label 2 "lblWSNumCrnt" and name label 4 "lblWSNumTotal".
Add the following around "for j = 0 to 2"
frmProgress.lblWSNumTotal.Caption = 3
for j = 0 to 2
frmProgress.lblWSNumCrnt.Caption = j + 1
DoEvents
This means the user will see the following with n stepping from 1 to 3 as the macro progesses:
Worksheet n of 3
Add another four labels for row number, and the following code around the k loop:
frmProgress.lblRowNumTotal.Caption = ubound(vdata, 1)
for k = 1 to ubound(vdata, 1)
frmProgress.lblRowNumCrnt.Caption = k
DoEvents
Now the user will see something like:
Worksheet 2 of 3
Row 1456 or 2450
The above technique is simple and does not involve any change to Jon49's code. The following technique, borrowed from Wrox's excellent Excel VBA Programmer's Reference, is a little more complicated but gives your macro a more professional appearance.
Create a label that runs across the entire form. Name it "lblToDo" and colour it white. Create another label of the same size over the top. Name it "lblDone" and colour it black.
Create a copy of the code to count the rows in each sheet at the top so you can calculate the total number of rows, "TotalRowsTotal", before you do anything else.
Create a new variable "TotalRowsCrnt", initialise it to zero and add one to it for every row in every worksheet.
Within the inner loop, add:
frmProgress.lblToDo.Width = _
frmProgress.lblDone.Width * TotalRowsCrnt / TotalRowsTotal
For Excel 2003, which all the organisations I work with still use, this gives a progress bar with the black Done label steadily covering the white ToDo label. Later version of Excel may offer a progress bar control as standard.
I hope this gives you some ideas for making your macros more attractive to your users.