My Problem is this:
I would like to use a custom ribbon Command button or even a simple command button inside the spreadsheet to initialize an OLEDB database connection and update/recalculate all the assoicated user defined functions that require such a connection, or those specified by me. I do not want any of these functions to recalculate except for when the specific button is clicked. I am having difficulty figuring out how to do this. Kindly offer your assistance or suggestions.
See below for Details on what I have done:
I currently store data within an access database from which I use vba in excel to make specific queries. I have embedded each datarequest routine within a group of functions under a module by the name [fnc]. I then access them as user-defined functions from within the excel spreadsheet. An example is given here:
Function ValueV(mm As String, yy As String, qtable As String, qcode As String, compare_period As Integer, average_period As Integer, weight As Boolean) As Variant
'Month Value Formula for Horizontal Data
'mm - month value 2-digit
'yy - year value 4-digit
'qtable - query table name eg. "cpia"
'qcode - query code for variable eg. "all0100"
'avgperiod - lag periods to average in calculation eg. 3-avgperiods for quarterly measure, 1-avgperiod for point measure.
'weight - boolean (true or false) value for weighting values given reference weight. Currently unsupported. Code should be extended to include this feature. (space holder for now)
Dim lag_value As Variant
Dim cur_value As Variant
lag_value = 0
cur_value = 0
'STEP-A: Gets the initial Value average or not.
'===============================================================
If compare_period > 0 Then
'Use this step to pickup initial value when compare_period <> 0 which requires a % change as opposed to a point value.
'Average_period must be greater than or equal to one (1). One (1) represents the current month which is the same as a point value.
lmm = fnc.lagdate(mm, yy, compare_period, "mm") 'lag month (a single month for mValueH)
lyy = fnc.lagdate(mm, yy, compare_period, "yy") 'lag year (a single month for mValueH)
smm = fnc.lagdate(mm, yy, compare_period + average_period - 1, "mm") 'dating backwards to account for average period
syy = fnc.lagdate(mm, yy, compare_period + average_period - 1, "yy") 'dating backwards to account for average period
'note, for smm & syy, the average period includes the lmm so we add back one (1)
'eg. 3-mth average is not 3-lags but current and 2-lags.
sdate1 = syy & fnc.numtext(smm)
'start date for query (begining of lag value including average period)
Set MyRecordset = New ADODB.Recordset
MySql = sql.sqlVSers(lmm, lyy, qtable, qcode, sdate1)
'MsgBox (MySql)
MyRecordset.Open MySql, MyConnect, adOpenStatic, adLockReadOnly
Do Until MyRecordset.EOF 'Loop to end and enter required values
lag_value = lag_value + MyRecordset(qcode)
MyRecordset.MoveNext
Loop
'Stop
lag_value = lag_value / average_period
MyRecordset.Close
End If
'STEP-B: Gets the current Value average or not.
'===============================================================
smm = fnc.lagdate(mm, yy, average_period - 1, "mm") 'dating backwards to account for average period
syy = fnc.lagdate(mm, yy, average_period - 1, "yy") 'dating backwards to account for average period
sdate1 = syy & fnc.numtext(smm)
'start date for query (begining of lag value including average period)
Set MyRecordset = New ADODB.Recordset
MySql = sql.sqlVSers(mm, yy, qtable, qcode, sdate1)
MyRecordset.Open MySql, MyConnect, adOpenStatic, adLockReadOnly
Do Until MyRecordset.EOF 'Loop to end and enter required values
cur_value = cur_value + MyRecordset(qcode)
MyRecordset.MoveNext
Loop
cur_value = cur_value / average_period
MyRecordset.Close
'STEP-C: Calculates the Requested % Change or Point Value.
'===============================================================
If compare_period = 0 Then
ValueV = cur_value
Else
ValueV = cur_value / lag_value * 100 - 100
End If
End Function
Since I totally bypass the use of a subroutine, the connection to the database is currently done as a workbook helper routine as shown below.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim filePath
filePath = ThisWorkbook.Path
If Right$(filePath, 1) <> "\" Then filePath = filePath & "\"
MyConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & filePath & "rsdata.accdb;"
End Sub
Problem is, this updating process is less than desirable. Idealy, I would like to position a custom button inside the menu bar that (upon clicking it) will connect to the database and recalculate all the userdefined functions that are used in a given worksheet or workbook.
Please offer your suggestions or point to where something like this may have been done before.
Thanks in advance.
JR.
You are trying to use UDF's for something they are not designed to do. What they are designed to do is behave just like other cell formula, and be calcutaed when Excel decides they need to be.
You have two options
redesign your application to not use UDF's (IMO the best way)
modify your UDFs to only respond to a trigger specified by you, eg a button click (IMO a cludge and generally bad idea)
How to redesign to avoid UDF's depend on factors not disclosed in your OP
Related
I am looking for a way to record the timings of multiple queries running in excel.
Preferably I would like all queries to refresh using refresh all then produce a separate table with the query names and duration of running time per query.
I have tried two methods currently but neither are doing exactly what I want:
Method 1
Time within the table
Source
https://eriksvensen.wordpress.com/2018/05/15/time-your-power-queries-powerbi-powerquery/
Result
This method didn't seem to work because apparently excel doesn't run the steps in the order noted on the right side of the query editor so the timings recorded at the start and end of the query was only a few seconds different when in real time they could be minutes apart.
Method 2
Time outside of table
Source
https://blog.crossjoin.co.uk/2014/11/17/timing-power-query-queries/
Result
This method seemed to work accurately but I couldn't find a way to add the time to the table without duplicating the query therefore doubling the real time to refresh.
Can anyone think of a way I can produce what I am after, either via a different method or by adjusting one of the above methods?
EDIT:
I think perhaps my only option would be to create a macro that refreshes each query individually by name, storing the time before and after each refresh as variables then to put these figures into a table once complete.
The best method I could come up with to achieve my goal was to write VBA that refreshed each query by name and stored the results in a table.
This is the code I created...
ListConnectons (To find the names to use in the next macro):
Sub ListConnections()
Dim cn As WorkbookConnection
Debug.Print "Name", "|", "Description", "|", "|", "RefreshWithRefreshAll", "|", "InModel", "|", "Type"
For Each cn In ThisWorkbook.Connections
Debug.Print cn.Name, "|", cn.Description, "|", cn.RefreshWithRefreshAll, "|", cn.InModel, "|", cn.Type
Next
End Sub
Query Timer (To run 2 queries and store times in a table):
Sub QueryTimer()
Dim StartTime As Double
Dim EndTime As Double
'##################
'##### Query 1 ####
'##################
Dim Query1 As Double
StartTime = Timer
Workbooks("workbook.xlsx").Sheets("Sheet1").Range("B2").Value = StartTime
Workbooks("workbook.xlsx").Connections("Query - Query 1").Refresh
EndTime = Timer
Workbooks("workbook.xlsx").Sheets("Sheet1").Range("C2").Value = EndTime
Query1 = Round(Round(EndTime - StartTime, 2) / 60, 2)
Workbooks("workbook.xlsx").Sheets("Sheet1").Range("D2").Value = Query1
'##################
'##### Query 2 ####
'##################
Dim Query2 As Double
StartTime = Timer
Workbooks("workbook.xlsx").Sheets("Sheet1").Range("B3").Value = StartTime
Workbooks("workbook.xlsx").Connections("Query - Query 2").Refresh
EndTime = Timer
Workbooks("workbook.xlsx").Sheets("Sheet1").Range("C3").Value = EndTime
Query2 = Round(Round(EndTime - StartTime, 2) / 60, 2)
Workbooks("workbook.xlsx").Sheets("Sheet1").Range("D3").Value = Query2
'##################
'#### Finished ####
Dim TotalTime As Double
TotalTime = Workbooks("workbook.xlsx").Sheets("Sheet1").Range("D4").Value
MsgBox "Refresh completed in " & Format(TotalTime, "0.0") & " Minutes."
End Sub
At work I am required to reformat incorrect Addresses on a weekly basis from records in our Salesforce instance. We gather the incorrectly formatted addresses using a Report and export them to an Excel file. My job is simply to manipulate the data in the file to format them properly then reinsert them into the database.
Typically the addresses are formatted as so:
5 Sesame Street, Anytown, Anyplace
Separating these can be done easily by hand, but I typically have to work with hundreds of addresses at a time, and using default excel formulas tends to require lots of wrangling multiple cells at once to break it up into fragments.
Thus I wrote a custom formula to run through the cell and return a specific fragment of the string based on the "Comma Number" given. So if I give a Comma Number of 1, I would get "5 Sesame Street", 2 would get me "Anytown", etc.
Here is my code so far:
Public Function fragmentAddress(address As String, numberofcommas As Integer) As String
seen = 1
lastComma = -1
Dim x As Long
Dim frag As Long
For x = 0 To Len(address)
If Mid(address, x, 1) = "," & numberofcommas = seen Then
Exit For
ElseIf Mid(address, x, 1) = "," & numberofcommas <> seen Then
seen = seen + 1
lastComma = x
End If
Next
frag = Mid(address, lastComma + 1, seen - lastComma)
fragmentAddress = frag
I have not implemented the ability to handle the final value yet, but it does not give me any outputs, only outputting a "#VALUE!" error when I attempt to give it the input
=fragmentAddress("3 Ashley Close, Charlton Kings",1)
I have some experience with programming, but this is my first time writing anything in VBA.
Any help would be appreciated, thank you.
Not exactly sure what your question is, but this is simpler:
Public Function GetAddressFragment(ByVal Address As String, ByVal Index As Integer) As String
Dim addr() As String
addr = Split(Address, ",")
On Error Resume Next
GetAddressFragment = Trim(addr(Index - 1))
End Function
Is there any way excel 2010 can lookup customer type by using meaningful part of customer name?
Example, The customer name is Littleton's Valley Market, but the list I am trying to look up the customer type the customer names are formatted little different such as <Littletons Valley MKT #2807 or/and Littleton Valley.
Some customer can be listed under multiple customer types, how can excel tell me what which customer and can I set excel to pull primary or secondary type?
Re #1. Fails on the leading < (if belongs!) and any other extraneous prefix but this may be rare or non-existent so:
=INDEX(G:G,MATCH(LEFT(A1,6)&"*",F:F,0))
or similar may catch enough to be useful. This looks at the first six characters but can be adjusted to suit, though unfortunately only once at a time. Assumes the mismatches are in ColumnA (eg A1 for the formula above) and that the correct names are in ColumnF with the required type in the corresponding row of ColumnG.
On a large scale Fuzzy Lookup may be helpful.
Since with a VBA tag Soundex matching and Levenshtein distance may be of interest.
Re #2 If secondary type is in ColumnH, again in matching row, then adjust G:G above to H:H.
pnuts gives a good answer re: Fuzzy Lookup, Soundex matching, etc. Quick and dirty way I've handled this before:
Function isNameLike(nameSearch As String, nameMatch As String) As Boolean
On Error GoTo ErrorHandler
If InStr(1, invalidChars(nameSearch), invalidChars(nameMatch), vbTextCompare) > 0 Then isNameLike = True
Exit Function
ErrorHandler:
isNameLike = False
End Function
Function invalidChars(strIn As String) As String
Dim i As Long
Dim sIn As String
Dim sOut As String
sOut = ""
On Error GoTo ErrorHandler
For i = 1 To Len(strIn)
sIn = Mid(strIn, i, 1)
If InStr(1, " 1234567890~`!##$%^&*()_-+={}|[]\:'<>?,./" & Chr(34), sIn, vbTextCompare) = 0 Then sOut = sOut & sIn
Next i
invalidChars = sOut
Exit Function
ErrorHandler:
invalidChars = strIn
End Function
Then I can call isNameLike from code, or use it as a formula in a worksheet. Note that you still have to supply the "significant" part of the customer name you're looking for.
I'm new to macros and vba in Excel. Currently, I'm working on a vba macro for an invoice template at work.
However, I'm running in a division by zero error that I'm having trouble tracing the cause of.
There are two specific lines of code where it pops up, sometimes..
First part:
VATRMB = 0
Second part:
VATRMB = VATRMB + (0.0593 * (ActiveSheet.Range("I" & i).Value / (1 + 0.0593)))
The Dim VATRMB is stored as follows:
Dim startRow As Integer, endRow As Integer, VATRMB As Single, VATEUR As Single, VATUSD As Single, VATRMBCell As Range, VATEURCell As Range, VATUSDCell As Range
The way I see it these lines should never throw up a division by zero error. In the first case there is no divisor whatsoever and in the second it is always positive.
Have any of you got an idea as to why this might cause an error? Could it have anything to do with the fact that the sub gets called multiple times, reusing the same VATRMB Dim? It should be reset after each call of the sub, right? Or could it have to do with the fact that I specify VATRMB as Single? This is appropriate for 'small' (sub-1,000,000) floating numbers, correct?
EDIT:
1. Added exact line used for calling Dim storage
2. Here is the full block of code used, maybe it helps to clarify a thing or two:
'Debug.Print Tab(10); ("Items will be searched in rows " & startRow & " thru " & endRow) 'Serves for debugging and testing
For i = startRow To endRow 'Loop the following code through all rows mentioned above
If ActiveSheet.Range("B" & i).Find("Membership") Is Nothing Then 'If nothing is returned when searching for "Membership"; i.e. if the item in this row is not a membership payment
If Not ActiveSheet.Range("H" & i).Find("RMB") Is Nothing Then 'If the value for this item is RMB denoted
'Debug.Print Tab(20); "Item on Row " & i & " is RMB denoted, VAT = " & ((ActiveSheet.Range("I" & i).Value / (1 + 0.0593)) * 0.0593) 'Serves for debugging and testing
VATRMB = VATRMB + (0.0593 * (ActiveSheet.Range("I" & i).Value / (1 + 0.0593))) 'Add row's VAT to VAT total
End If
If Not ActiveSheet.Range("H" & i).Find("EUR") Is Nothing Then 'If the value for this item is EUR denoted
'Debug.Print Tab(20); "Item on Row " & i & " is EUR denoted, VAT = " & ((ActiveSheet.Range("I" & i).Value / (1 + 0.0593)) * 0.0593) 'Serves for debugging and testing
'MsgBox VATEUR + 0.0593 * ActiveSheet.Range("I" & i).Value / (1 + 0.0593)
VATEUR = VATEUR + (0.0593 * (ActiveSheet.Range("I" & i).Value / (1 + 0.0593))) 'Add row's VAT to VAT total
End If
If Not ActiveSheet.Range("H" & i).Find("USD") Is Nothing Then 'If the value for this item is USD denoted
'Debug.Print Tab(20); "Item on Row " & i & " is USD denoted, VAT = " & ((ActiveSheet.Range("I" & i).Value / (1 + 0.0593)) * 0.0593) 'Serves for debugging and testing
VATUSD = VATUSD + (0.0593 * (ActiveSheet.Range("I" & i).Value / (1 + 0.0593))) 'Add row's VAT to VAT total
End If
Else 'Else, i.e. if the row contains a membership payment, then essentially nothing happens
'Debug.Print Tab(20); ("Item on Row " & i & " is a membership payment; no VAT paid.") 'Serves for debugging and testing
End If
Next
So what I'm trying to do is basically loop through all the items in the invoice, from startRow to endRow, and determine whether the item is a membership payment by parsing the 'type' string (column B). Then, depending on whether or not it is a membership payment determine the VAT, also checking the currency in which it is paid. The amount for the payment is stored in Column I as a floating number.
Not sure if this is the answer to your problems since you would need to provide the entirety of your workbooks etc to confirm. Nevertheless, we can create this type of "it should be impossible" situation with 100% reproducibility for not only Div0, but also for pretty much any error, with a line like:
VarX = 10 ' we can make this fail with Div0, Overflow or whatever
In our test, the problem is not actually the "direct" or "explicit" code where the error is reported, but rather, the error occurs elsewhere, and VBA in its infinite wisdom just happens to "report" the error in an odd way at an odd time (in fact it should not be reporting certain errors at all, see below).
Does your package involve any external executables, dll's, addins', etc?
If so, then that is likely the place to start.
If not, the error may actually be occurring directly or indirectly in the Range you are accessing, but not necessarily in the cell currently accessed.
Here is an example creating a "Div0" via a DLL accessed in VBA as an addin: Suppose you write a bit of code in another language, here Fortran (we use Implicit None everywhere, and everything is declared correctly etc.):
Pure Subroutine FortDLL(x, U)
:
Real(DP), Intent(In) :: x
Real(DP), Intent(Out) :: U
:
Real(DP) :: QQ
:
:
QQ = Log10(x) ! Notice this is not the return var and has nothing to do with anything on the VBA side (or so you would think)
:
U = 10.D0 ! Notice, this is the return var, and is a constant = 10.D0
:
End Subroutine FortDLL
compile as DLL and access in the usual way.
Then suppose you have some VBA as:
Function VBAFunc(x) as Variant
:
Call FortDLL(x, U)
:
Dim VarU as Variant
:
VarU = U ; you can replace this with VarU = 10, or whatever, and will get same result/failure
Now, if x < 0, then the DLL will crap out since Log10 is not defined for x < 0. This will throw a Fortran run time error, and depending on how you set this up, you can get it to throw a Div0, an Overflow (e.g. on the Fortran side the MaxExponent for a Double here is 1024, whereas on the VBA side it is around 308 depending on a number of things, etc. etc. etc. )
Now even though QQ has nothing at all to do with the VBA side, when the VBA code executes FortDLL(), it returns U = 10, and it actually does that part correctly.
HOWEVER, the DLL would have thrown a Div0 (or whatever you desire to create) error, and that "error message" is/can be buried in the return to the Call FortDLL().
If you are not using DLL's etc, it is possible that something comparable is happening in your "range" or elsewhere during you looping etc.
We have not performed explicit tests as to why the Dim as Currency "fix" works, but we are guessing that as Currency is a very special Type (it is actually a structured type with at least TWO fields), the "error message" may be buried in one of those "fields", and which may not be required/relevant to the size of number you are using, and obviating the crash by "fluke" (i.e. a kind of "lucky KLUDGE". You can test this by putting in numbers too large for Double, and requiring the full machinery of the Currency Type. If it is a "lucky KLUDGE", then one day when you are not around and somebody else is using your code, and they enter a number requiring the full Currency machinery, then it will likely crash, and nobody will know why.
Here is an alternate test, suppose you have the crash on a line like VarX = 10, then replace/amend as follows:
:
On Error Resume Next
VarX = 10
VarX = 10
:
... if this "works" (i.e. obviates the error/crash), then your problem is likely along the lines explained above (whether "external" or "internal"). In this case, basically, the "Div0 problem" is treated as a VBA error on the first time VarX is assigned 10, since the Error Trap is set, that "first time" catches and ignores the "DLL side error", and moves on.
... clearly this is just a TEST, not a solution.
This may also be Excel/Win/Compiler (and especially with GCC, compiler VERSION also since they have some pretty wacky things/changes sometimes) dependent and so the reproducibility and exact behaviour may vary.
I am trying to extract tables from pdf files with vba and export them to excel. If everything works out the way it should, it should go all automatic. The problem is that the table are not standardized.
This is what I have so far.
VBA (Excel) runs XPDF, and converts all .pdf files found in current folder to a text file.
VBA (Excel) reads through each text file line by line.
And the code:
With New Scripting.FileSystemObject
With .OpenTextFile(strFileName, 1, False, 0)
If Not .AtEndOfStream Then .SkipLine
Do Until .AtEndOfStream
//do something
Loop
End With
End With
This all works great. But now I am getting to the issue of extracting the tables from the text files.
What I am trying to do is VBA to find a string e.g. "Year's Income", and then output the data, after it, into columns. (Until the table ends.)
The first part is not very difficult (find a certain string), but how would I go about the second part. The text file will look like this Pastebin. The problem is that the text is not standardized. Thus for example some tables have 3-year columns (2010 2011 2012) and some only two (or 1), some tables have more spaces between the columnn, and some do not include certain rows (such as Capital Asset, net).
I was thinking about doing something like this but not sure how to go about it in VBA.
Find user defined string. eg. "Table 1: Years' Return."
a. Next line find years; if there are two we will need three columns in output (titles +, 2x year), if there are three we will need four (titles +, 3x year).. etc
b. Create title column + column for each year.
When reaching end of line, go to next line
a. Read text -> output to column 1.
b. Recognize spaces (Are spaces > 3?) as start of column 2. Read numbers -> output to column 2.
c. (if column = 3) Recognize spaces as start of column 3. Read numbers -> output to column 3.
d. (if column = 4) Recognize spaces as start of column 4. Read numbers -> output to column 4.
Each line, loop 4.
Next line does not include any numbers - End table. (probably the easiet just a user defined number, after 15 characters no number? end table)
I based my first version on Pdf to excel, but reading online people do not recommend OpenFile but rather FileSystemObject (even though it seems to be a lot slower).
Any pointers to get me started, mainly on step 2?
You have a number of ways to dissect a text file and depending on how complex it is might cause you to lean one way or another. I started this and it got a bit out of hand... enjoy.
Based on the sample you've provided and the additional comments, I noted the following. Some of these may work well for simple files but can get unwieldy with bigger more complex files. Furthermore, there may be slightly more efficient methods or tricks to what I have used here but this will definitely get you going an achieve the desired outcome. Hopefully this makes sense in conjunction with the code provided:
You can use booleans to help you determine what 'section' of the text file you are in. Ie use InStr on the current line to
determine you are in a Table by looking for the text 'Table' and then
once you know you are in the 'Table' section of the file start
looking for the 'Assets' section etc
You can use a few methods to determine the number of years (or columns) you have. The Split function along with a loop will do
the job.
If your files always have constant formatting, even only in certain parts, you can take advantage of this. For example, if you know your
file line will always have a dollar sign in front of the them, then
you know this will define the column widths and you can use this on
subsequent lines of text.
The following code will extract the Assets details from the text file, you can mod it to extract other sections. It should handle multiple rows. Hopefully I've commented it sufficient. Have a look and I'll edit if needs to help out further.
Sub ReadInTextFile()
Dim fs As Scripting.FileSystemObject, fsFile As Scripting.TextStream
Dim sFileName As String, sLine As String, vYears As Variant
Dim iNoColumns As Integer, ii As Integer, iCount As Integer
Dim bIsTable As Boolean, bIsAssets As Boolean, bIsLiabilities As Boolean, bIsNetAssets As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
sFileName = "G:\Sample.txt"
Set fsFile = fs.OpenTextFile(sFileName, 1, False)
'Loop through the file as you've already done
Do While fsFile.AtEndOfStream <> True
'Determine flag positions in text file
sLine = fsFile.Readline
Debug.Print VBA.Len(sLine)
'Always skip empty lines (including single spaceS)
If VBA.Len(sLine) > 1 Then
'We've found a new table so we can reset the booleans
If VBA.InStr(1, sLine, "Table") > 0 Then
bIsTable = True
bIsAssets = False
bIsNetAssets = False
bIsLiabilities = False
iNoColumns = 0
End If
'Perhaps you want to also have some sort of way to designate that a table has finished. Like so
If VBA.Instr(1, sLine, "Some text that designates the end of the table") Then
bIsTable = False
End If
'If we're in the table section then we want to read in the data
If bIsTable Then
'Check for your different sections. You could make this constant if your text file allowed it.
If VBA.InStr(1, sLine, "Assets") > 0 And VBA.InStr(1, sLine, "Net") = 0 Then bIsAssets = True: bIsLiabilities = False: bIsNetAssets = False
If VBA.InStr(1, sLine, "Liabilities") > 0 Then bIsAssets = False: bIsLiabilities = True: bIsNetAssets = False
If VBA.InStr(1, sLine, "Net Assests") > 0 Then bIsAssets = True: bIsLiabilities = False: bIsNetAssets = True
'If we haven't triggered any of these booleans then we're at the column headings
If Not bIsAssets And Not bIsLiabilities And Not bIsNetAssets And VBA.InStr(1, sLine, "Table") = 0 Then
'Trim the current line to remove leading and trailing spaces then use the split function to determine the number of years
vYears = VBA.Split(VBA.Trim$(sLine), " ")
For ii = LBound(vYears) To UBound(vYears)
If VBA.Len(vYears(ii)) > 0 Then iNoColumns = iNoColumns + 1
Next ii
'Now we can redefine some variables to hold the information (you'll want to redim after you've collected the info)
ReDim sAssets(1 To iNoColumns + 1, 1 To 100) As String
ReDim iColumns(1 To iNoColumns) As Integer
Else
If bIsAssets Then
'Skip the heading line
If Not VBA.Trim$(sLine) = "Assets" Then
'Increment the counter
iCount = iCount + 1
'If iCount reaches it's limit you'll have to redim preseve you sAssets array (I'll leave this to you)
If iCount > 99 Then
'You'll find other posts on stackoverflow to do this
End If
'This will happen on the first row, it'll happen everytime you
'hit a $ sign but you could code to only do so the first time
If VBA.InStr(1, sLine, "$") > 0 Then
iColumns(1) = VBA.InStr(1, sLine, "$")
For ii = 2 To iNoColumns
'We need to start at the next character across
iColumns(ii) = VBA.InStr(iColumns(ii - 1) + 1, sLine, "$")
Next ii
End If
'The first part (the name) is simply up to the $ sign (trimmed of spaces)
sAssets(1, iCount) = VBA.Trim$(VBA.Mid$(sLine, 1, iColumns(1) - 1))
For ii = 2 To iNoColumns
'Then we can loop around for the rest
sAssets(ii, iCount) = VBA.Trim$(VBA.Mid$(sLine, iColumns(ii) + 1, iColumns(ii) - iColumns(ii - 1)))
Next ii
'Now do the last column
If VBA.Len(sLine) > iColumns(iNoColumns) Then
sAssets(iNoColumns + 1, iCount) = VBA.Trim$(VBA.Right$(sLine, VBA.Len(sLine) - iColumns(iNoColumns)))
End If
Else
'Reset the counter
iCount = 0
End If
End If
End If
End If
End If
Loop
'Clean up
fsFile.Close
Set fsFile = Nothing
Set fs = Nothing
End Sub
I cannot examine the sample data as the PasteBin has been removed. Based on what I can glean from the problem description, it seems to me that using Regular Expressions would make parsing the data much easier.
Add a reference to the Scripting Runtime scrrun.dll for the FileSystemObject.
Add a reference to the Microsoft VBScript Regular Expressions 5.5. library for the RegExp object.
Instantiate a RegEx object with
Dim objRE As New RegExp
Set the Pattern property to "(\bd{4}\b){1,3}"
The above pattern should match on lines containing strings like:
2010
2010 2011
2010 2011 2012
The number of spaces between the year strings is irrelevant, as long as there is at least one (since we're not expecting to encounter strings like 201020112012 for example)
Set the Global property to True
The captured groups will be found in the individual Match objects from the MatchCollection returned by the Execute method of the RegEx object objRE. So declare the appropriate objects:
Dim objMatches as MatchCollection
Dim objMatch as Match
Dim intMatchCount 'tells you how many year strings were found, if any
Assuming you've set up a FileSystemObject object and are scanning the text file, reading each line into a variable strLine
First test to see if the current line contains the pattern sought:
If objRE.Test(strLine) Then
'do something
Else
'skip over this line
End If
Set objMatches = objRe.Execute(strLine)
intMatchCount = objMatches.Count
For i = 0 To intMatchCount - 1
'processing code such as writing the years as column headings in Excel
Set objMatch = objMatches(i)
e.g. ActiveCell.Value = objMatch.Value
'subsequent lines beneath the line containing the year strings should
'have the amounts, which may be captured in a similar fashion using an
'additional RegExp object and a Pattern such as "(\b\d+\b){1,3}" for
'whole numbers or "(\b\d+\.\d+\b){1,3}" for floats. For currency, you
'can use "(\b\$\d+\.\d{2}\b){1,3}"
Next i
This is just a rough outline of how I would approach this challenge. I hope there is something in this code outline that will be of help to you.
Another way to do this I have some success with is to use VBA to convert to a .doc or .docx file and then search for and pull tables from the Word file. They can be easily extracted into Excel sheets. The conversion seems to handle tables nicely. Note however that it works on a page by page basis so tables extending over a page end up as separate tables in the word doc.