VBA to export table to fixed width format is producing error "Variable not defined" - excel

I'm using the following beautiful solution by Jamie Riis from this post.
Option Explicit
Option Base 1 'This makes any defined array start a 1 rather than 0
Sub Export_Selection_As_Fixed_Length_File()
' Dimension all variables.
Dim DestinationFile, CellValue, Filler_Char_To_Replace_Blanks As String
Dim FileNum, ColumnCount, RowCount, FieldWidth As Integer
Dim sht As Worksheet
Dim outputRecord() As String
'Below are options in case you want to change the folder where VBA stores the .txt file
'We use ActiveWorkbook.Path in this example
'ActiveWorkbook.Path 'the activeworkbook
'ThisWorkbook.Path 'the workbook with the code
'CurDir 'the current directory (when you hit File|open)
'If a cell is blank, what character should be used instead
Filler_Char_To_Replace_Blanks = "+"
'Check if the user has made any selection at all
If Selection.Cells.Count < 2 Then
MsgBox "Nothing selected to export"
Selection.Activate
End
End If
'This is the destination file name.
DestinationFile = ActiveWorkbook.Path & "/textfile.txt" 'This was changed to the DOS version of directory separator
On Error GoTo catchFileOpenError 'Poor man's version of Try/Catch
'Get a FileSystemObject using the MSFT Scripting Runtime reference
Dim fd As Scripting.FileSystemObject
Set fd = New Scripting.FileSystemObject
Dim outputFile As Object
Set outputFile = fd.CreateTextFile(DestinationFile, True, False)
' Turn error checking on.
On Error GoTo 0
Dim record As Scripting.Dictionary
'Call a private function that gets the filed control information from the
'Sheet titled FieldControl and the associated range
Set record = GetFieldControl(ActiveWorkbook.Sheets("FieldControl").Range("A2:D56"))
'Declare enumerators to loop through the selection
Dim dataRow As Range
Dim dataFld As Range
'Declare the output buffer, 80 characters
Dim outputBuffer(80) As Byte
'loop thru the selection row by row
For Each dataRow In Selection.Rows
'Initialize buffer to empty value defined by the second parameter
Call InitOutputBuffer(outputBuffer, Filler_Char_To_Replace_Blanks)
'Loop thru each field in the row
For Each dataFld In dataRow.Columns
'Copy the input value into the output byte array
Call CopyStringToByteArray(outputBuffer, StrConv(Trim(CStr(dataFld.Value2)), vbFromUnicode), _
record(dataFld.Column).StartPos, record(dataFld.Column).FieldType, record(dataFld.Column).Size)
Next dataFld
'Write the record to the text file but first convert ASCII Byte to Unicode String
'Also this method places CR/LF as part of the output to the file
outputFile.WriteLine StrConv(outputBuffer, vbUnicode)
Next dataRow
' Close destination file.
outputFile.Close
Selection.Activate
Workbooks.OpenText Filename:=DestinationFile
Exit Sub
catchFileOpenError: 'Catch the error after trying if openning the file fails
On Error GoTo 0
MsgBox "Cannot open filename " & DestinationFile
Selection.Activate
End Sub
'***********************************************************************************
'*
'* PARAMETERS:
'* outBuf is the updated buffer
'* inBuf is the input buffer that needs to be copied to the output buffer (buffer)
'* startCol is the starting column for the field
'* fldTy is the field type as defined by the class enumerator eFieldType
'* fldLen is the length of the field as defined on the control sheet
Private Sub CopyStringToByteArray(ByRef outBuf() As Byte, ByRef inBuf() As Byte, _
ByVal startCol As Long, ByRef fldTy As eFieldType, ByVal fldLen As Long)
Dim idx As Long
If fldTy = Text Then 'Left Justified
For idx = LBound(inBuf) To UBound(inBuf)
outBuf(startCol) = inBuf(idx)
startCol = startCol + 1
Next idx
Else 'Right Justified
Dim revIdx As Long
revIdx = startCol + fldLen - 1
For idx = UBound(inBuf) To LBound(inBuf) Step -1
outBuf(revIdx) = inBuf(idx)
revIdx = revIdx - 1
Next idx
End If
End Sub
'***************************************************************************
'* InitOutputBuffer
'* PARAMETERS:
'* buffer is the buffer to initialize
'* initVal is a string containing the value used to initialize the buffer
Private Sub InitOutputBuffer(ByRef buffer() As Byte, ByVal initVal As String)
Dim byInitVal() As Byte 'Byte array to hold the values from the string conversion
byInitVal = StrConv(initVal, vbFromUnicode) 'convert the string into an ASCII array
Dim idx As Long
For idx = LBound(buffer) To UBound(buffer)
buffer(idx) = byInitVal(0)
Next idx
'buffer(81) = Asc(Chr(13)) 'Carriage Return Character
'buffer(82) = Asc(Chr(10)) 'Line Feed Character
End Sub
'*******************************************************************************
'*
'* GetFieldControl
'* PARAMETERS:
'* ctrlRng is the range on a worksheet where the field control info is
'* found
'* REMARKS:
'* The range needs to have the following columns: Name, Size, Start Postion
'* and Type. Type values can be Text or Number
Private Function GetFieldControl(ByRef ctrlRng As Range) As Scripting.Dictionary
Dim retVal As Scripting.Dictionary
Set retVal = New Scripting.Dictionary
'format of control range is : Name, Size, Start Position, Type
Dim fldInfoRow As Range
Dim fld As clField 'A class that holds the control values from the work sheet
Dim colCnt As Long: colCnt = 1 'Becomes the key for the dictionary
For Each fldInfoRow In ctrlRng.Rows
Set fld = New clField
fld.Name = fldInfoRow.Value2(1, 1) 'Name of field in data table
fld.Size = fldInfoRow.Value2(1, 2) 'Output Size of field
fld.StartPos = fldInfoRow.Value2(1, 3) 'Output starting position for this field
Select Case fldInfoRow.Value2(1, 4) 'Controls how the output value is formated
Case "Text" ' Text left justified, Numbers are right justified
fld.FieldType = Text
Case "Number"
fld.FieldType = Number
Case Default
fld.FieldType = Text
End Select
retVal.Add Key:=colCnt, Item:=fld 'Add the key and the fld object to the dictionary
colCnt = colCnt + 1 'This key value is mapped to the column number in the input data table
Next fldInfoRow
'Return the scripting Dictionary
Set GetFieldControl = retVal
End Function
I've
set up the FieldControl sheet to define the parameters for every column
set up the Class module clField
updated the range to capture the new dimensions of the table in the FieldControl sheet
added Microsoft Scripting Runtime reference to my macro workbook
selected an appropriate portion of the source table to export
However, when running it I'm getting a compile error "Variable not defined" with the first line of this section highlighted.
Anyone please able to help to resolving?

Related

Exception Visual Basic .NET Clipboard Text to Excel Via Interop/Worksheet.Paste()

Trying to get an older VB.NET application working again. One feature builds a text string composed of text delimited by Tab/Return characters, then creates (via interop) an Excel Workbook, adds a Worksheet, and (desired) paste the text string into the worksheet.
Here is the code:
Private Function AddNewWorksheetToWorkbook(
ByVal theWorkbook As Workbook,
ByVal worksheetName As String,
ByVal textToPaste As String
) As Microsoft.Office.Interop.Excel.Worksheet
Dim newWorksheet As Microsoft.Office.Interop.Excel.Worksheet
newWorksheet = theWorkbook.Worksheets.Add()
newWorksheet.Name = worksheetName
theWorkbook.Save()
newWorksheet.Activate() 'All works fine, file saved, worksheet named and Active as desired
Dim app As Microsoft.Office.Interop.Excel.Application
app = newWorksheet.Application
If app.ActiveSheet.Name = newWorksheet.Name Then 'Just a test to make sure ActiveSheet is the one desired -- it is
Clipboard.SetText(textToPaste) 'Clipboard has text delimited by vbTab and vbReturn (a "plain" text table)
newWorksheet.Range("A1").Select() 'Cell "A1" is properly selected
newWorksheet.Paste() 'BOOM! Get System.Runtime.InteropServices.COMException: 'Microsoft Excel cannot paste the data.'
End If
theWorkbook.Save()
Return newWorksheet
End Function
As noted in the comments, all goes well until the Worksheet.Paste() method call.
I have tried variations on Paste() as well as PasteSpecial(), etc. No joy.
Keep getting System.Runtime.InteropServices.COMException: 'Microsoft Excel cannot paste the data.'
I am able to (manually, not through interop) click "Paste" in Excel and it works just fine.
I would be grateful for any insights from the stackoverflow community!
So, here is what I ended up doing to solve (actually avoid and solve) the problem I was facing. Here is how I altered the existing function.
Private Function AddNewWorksheetToWorkbook(
ByVal theWorkbook As Workbook,
ByVal worksheetName As String,
ByVal textToPaste As String
) As Microsoft.Office.Interop.Excel.Worksheet
Dim newWorksheet As Microsoft.Office.Interop.Excel.Worksheet
newWorksheet = theWorkbook.Worksheets.Add()
newWorksheet.Name = worksheetName
theWorkbook.Save()
newWorksheet.Activate() 'All works fine, file saved, worksheet named and Active as desired
Dim app As Microsoft.Office.Interop.Excel.Application
app = newWorksheet.Application
If app.ActiveSheet.Name = newWorksheet.Name Then
Dim rowCount As Integer = 0
Dim colCount As Integer = 0
Dim values(,) As String = ExtractTwoDimDataSet(pasteText, rowCount, colCount)
Dim oRange As Range
oRange = newWorksheet.Range(newWorksheet.Cells(1, 1), newWorksheet.Cells(rowCount, colCount))
oRange.Value = values
End If
theWorkbook.Save()
Return newWorksheet
End Function
The change, of course, is to not use the Clipboard at all (which users might appreciate) and assign the "two-dimensional" text array to a Cell range on the Worksheet. The function (yes, I know, ugly with return values and ByRef parameters) is as follows:
Private Shared Function ExtractTwoDimDataSet(tabAndCrLfDelimitedText As String, ByRef rowCount As Integer, ByRef colCount As Integer) As String(,)
rowCount = 0
colCount = 0
Dim rows() As String
Dim columns() As String
rows = Split(tabAndCrLfDelimitedText, vbCrLf)
rowCount = rows.Length
For Each line As String In rows
columns = Split(line, vbTab)
If columns.Length > colCount Then
colCount = columns.Length
End If
Next
Dim values(rowCount, colCount) As String
rows = Split(tabAndCrLfDelimitedText, vbCrLf)
Dim r As Integer = 0
For Each line As String In rows
columns = Split(line, vbTab)
Dim c As Integer = 0
For Each cell As String In columns
values(r, c) = cell
c = c + 1
Next
r = r + 1
Next
Return values
End Function
The end result does what it needs to do and the function above is fairly reusable but I marked it Private as it is not general-purpose, and depends on the vbCrLf and vbTab delimiters.
This is clearly in the spirit of advice from #Mary ...
Thanks for the views and suggestions from stackoverflow folks!

Excel loses data when second workbook is closed

EDIT at the bottom of the question
I have a function in my code, that gets a dictionary of samples, fills in data from another workbook and returns filled dictionary. Everything worked fine, but once I changed the opening of the file to be ReadOnly, I experience problems.
Here is the code (which has been simplified to remove redundant parts):
Function get_samples_data(ByVal instructions As Scripting.Dictionary, ByRef patients_data As Scripting.Dictionary) As Scripting.Dictionary
'takes a dictionary of samples and fills their data from the file <0 GL all RL>
Dim wb As Workbook
Dim ws As Worksheet
Dim data_start As Long
Dim data_end As Long
Dim rw As Range
Dim rw_nr As String
'open <GP all> in ReadOnly mode based on path and filename in specific cells
Application.ScreenUpdating = False
Set wb = Workbooks.Open(ThisWorkbook.Sheets(1).Cells(13, 2).Value2 & ThisWorkbook.Sheets(1).Cells(13, 1).Value2, False, True)
Set ws = wb.Worksheets("ALL")
'get row nr. of the first and the last sample to export
data_start = ws.Columns("A:A").Find(what:=instructions("from_sample"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).Row
data_end = ws.Columns("A:A").Find(what:=instructions("to_sample"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).Row
'main loop
For i = data_start To data_end
Set rw = ws.Rows(i)
rw_nr = rw.Cells(1, 1).Value
If rw.Cells(1, 11).Value = instructions("group") Then
If patients_data.Exists(rw_nr) Then
Set patients_data(rw_nr) = fetch_sample_data(rw, patients_data(rw_nr))
End If
End If
Next
'close <GP all> without saving
wb.Close (False)
Set get_samples_data = patients_data
End Function
When I debugged, I noticed, that the data is lost on the call of wb.Close(False). Until that point data is intact, but once the source workbook is closed, the data (which is a range object) is turned blank. Not set to nothing, which happens when the data is not found in the source workbook, but all properties of the range object can be seen in debugger, but all have a value of .
Before I changed the openmode to ReadOnly, everything worked and data stayed there.
What did I miss? Why are data, stored in a different variable, lost?
EDIT:
Fetch sample data indeed returns a range object.
Private Function fetch_sample_data(ByVal rw As Range, ByRef sm As sample) As sample
Dim data As Range
Set data = Range(rw.Cells(1, 19), rw.Cells(1, 63))
Set sm.data = data
Set fetch_sample_data = sm
End Function
I tried changing the order of closing and setting the return value, but the error prevails.
Is it so then, that a Range object is always only a reference to a range in a worksheet? If I want the data to stay, do I need to change all Range objects in question to arrays? Or is there a way to create a Range object independent of a workbook (I do not want to copy the range into any sheet in the main workbook carrying the macro)?
Below is the main sub, as #Pᴇʜ asked for it. I will not add the remaining functions, because the whole code is scattered over 1 form, 2 modules and 14 classes (many carrying long methods).
The two commented open commands are those that caused everything to work properly. The closing commands were at the end of main sub, so in regards to the comment of #Pᴇʜ, if range object is always only a reference to an actual range of cells, they were available for the whole duration of the program.
Sub RL_creator_GP_main()
Dim instructions As New Scripting.Dictionary
Dim samples As Scripting.Dictionary
Dim result_list As Variant
Dim rep As cReport
Dim scribe As New descriptor
Application.ScreenUpdating = False
'get instructions from inputboxes (group, from sample, to sample)
Set instructions = procedures.input_instructions()
If instructions.Exists("terminated") Then
Exit Sub
End If
'get <GP all> and <RL headers> ready
'Call procedures.prepare_file("GP all.xlsx", pth:=ThisWorkbook.Sheets(1).Cells(12, 2).Value)
'Call procedures.prepare_file("RL headers.xlsx", pth:=ThisWorkbook.Sheets(1).Cells(13, 2).Value)
'get patients data from <RL headers>, closes the file afterwards
Set samples = procedures.get_patients_data(instructions)
'get patients data from <GP all>, closes the file afterwards
Set samples = procedures.get_samples_data(instructions, samples)
because samples is submitted ByRef to get_samples_data you don't need to return it:
Sub RL_creator_GP_main()
'your code here …
'get patients data from <RL headers>, closes the file afterwards
Set samples = procedures.get_patients_data(instructions)
'get patients data from <GP all>, closes the file afterwards
procedures.get_samples_data instructions, samples 'this call will change the original samples because it is ByRef!
In fetch_sample_data you add a range to your dictionary. But a Range object is only a reference to the worksheet and does not contain data itself. So instead of that turn the range into an array to add the actual data instead of only a reference:
Private Sub fetch_sample_data(ByVal rw As Range, ByRef sm As sample)
Dim data() As Variant
data = Range(rw.Cells(1, 19), rw.Cells(1, 63)).Value
Set sm.data = data
'again you don't need a function to return the sample as it is ByRef
End Sub
Finally get_samples_data should be a sub not a function. And call fetch_sample_data as a sub like fetch_sample_data rw, patients_data(rw_nr)
Sub get_samples_data(ByVal instructions As Scripting.Dictionary, ByRef patients_data As Scripting.Dictionary)
'takes a dictionary of samples and fills their data from the file <0 GL all RL>
Dim wb As Workbook
Dim ws As Worksheet
Dim data_start As Long
Dim data_end As Long
Dim rw As Range
Dim rw_nr As String
'open <GP all> in ReadOnly mode based on path and filename in specific cells
Application.ScreenUpdating = False
Set wb = Workbooks.Open(ThisWorkbook.Sheets(1).Cells(13, 2).Value2 & ThisWorkbook.Sheets(1).Cells(13, 1).Value2, False, True)
Set ws = wb.Worksheets("ALL")
'get row nr. of the first and the last sample to export
data_start = ws.Columns("A:A").Find(what:=instructions("from_sample"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).Row
data_end = ws.Columns("A:A").Find(what:=instructions("to_sample"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).Row
'main loop
For i = data_start To data_end
Set rw = ws.Rows(i)
rw_nr = rw.Cells(1, 1).Value
If rw.Cells(1, 11).Value = instructions("group") Then
If patients_data.Exists(rw_nr) Then
fetch_sample_data rw, patients_data(rw_nr)
End If
End If
Next
'close <GP all> without saving
wb.Close (False)
End Sub
Background explanation
Calling functions and subs:
First of all the Call statement is not needed. Parameters in functions are always in parenhesis, the function is used to return a value.
Result = MyFunction(Param1, Param2) ' functions return a result and parameters are in parentesis
MySub Param1, Param2 ' subs don't return a result and don't use parentesis
Call MySub(Param1, Param2) ' But with the Call statement they need parentesis
What does ByRef do:
If you declare a parameter ByRef that means you don't submit data to the sub but only a reference (By Reference) to that data in the memory. So if you have the following sub:
Sub MySub(ByVal Param1, ByRef Param2)
Param1 = 1
Param2 = 2
End Sub
And use it like
Sub Example()
Dim Var1 As Long: Var1 = 10
Dim Var2 As Long: Var2 = 20
MySub Var1, Var2 'note Var2 is submitted ByRef!
Debug.Print Var1, Var2 'returns 10, 2 the value in Var2 got changed by MySub without returning anything
End Sub
So when you submit the variabe by reference that means MySub changes the value in Var2 when performing Param2 = 2 because Param2 and Var2 reference the same space in memory. While if you submit ByVal (by value) you actually make a copy of the data in the memory and Param1 and Var1 reference different places in the memory.
That is why you don't need a function to return something if you submit it ByRef you already changed the data in the memory.
So in your code if you declare Sub get_samples_data(ByVal instructions As Scripting.Dictionary, ByRef patients_data As Scripting.Dictionary) then calling it like procedures.get_samples_data instructions, samples makes patients_data and samples point to the same space in memory. So because the data is only once in the memory and there is only 2 links pointing to them any changes made in one of the links actually edits the exact same data in memory. Therefore you don't need to return data.

Reading Date from Excel file in VBA Error Message

I have a function that gets the date from a certain cell in an excel sheet, splits the string that was in that cell using a space as a delimiter and keeps the first object in the array to store at as the date. However, I keep getting the following error message
"run-time error '91': Object variable or With block variable not set".
Any ideas of what might be wrong?
Public Function getDate(ws As Excel.Worksheet, row As Integer, col As Integer) As String
Dim inspDateTime As Variant
Dim dateArr() As String
Dim inspDateFinal As String
Set inspDateTime = ws.Cells(row, col)
dateArr = Split(inspDateTime, " ")
inspDateFinal = dateArr(0)
getDate = inspDateFinal
End Function
The following code is how I call the function:
Private Sub UploadData_Click()
Dim myWorkbook As Excel.Workbook
Dim myWorksheet As Excel.Worksheet
Dim inspDate As String
inspDate = getDate(myWorksheet, 10, 14)
' setting the workbook as the directory that was printed to the text box
Set myWorkbook = Workbooks.Open(Me.FilePathTxtBox)
' setting the first worksheet in the array of files entered
Set myWorksheet = myWorkbook.Worksheets(1)
End Sub

VBA-excel dictionary

Im copying cells from one sheet to another, finding and matching column header names and pasting to the correct cell. These column header names differ slightly per sheet, altough they contain the same data. My working code has a lot of repetition:
' sub that finds head in a specified worksheet and sets rngCol variable
Sub rngByHead(Sheet As Worksheet, head As String)
' sub for copying data
With Source1
' find and set producer, note name difference)
Call rngByHead(Source1, "bedrijfsnaam")
Dim producent As String
producent = .Cells(docSource1.Row, rngCol).Value
' find and set Fase
Call rngByHead(Source1, "Fase")
Dim fase As String
fase = .Cells(docSource1.Row, rngCol).Value
' find and set Status
Call rngByHead(Source1, "Status")
Dim status As String
status = .Cells(docSource1.Row, rngCol).Value
' find and set versionnumber, note name difference
Call rngByHead(Source1, "Wijziging")
Dim versienummer As String
versienummer = .Cells(docSource1.Row, rngCol).Value
End With
With Target
' find and write all variables to uploadlijst
Call rngByHead(Target, "bestandsnaam")
.Cells(cell.Row, rngCol).Value = bestand
Call rngByHead(Target, "producent")
.Cells(cell.Row, rngCol).Value = producent
Call rngByHead(Target, "fase")
.Cells(cell.Row, rngCol).Value = LCase(fase)
Call rngByHead(Target, "status")
.Cells(cell.Row, rngCol).Value = LCase(status)
Call rngByHead(Target, "versienummer")
.Cells(cell.Row, rngCol).Value = versienummer
End With
I was trying a more cleaner option with a dictionary for matching the different header names in target and data sheets. I also created a secong dictionary to store those values under the specific keys. I keep getting errors on this code, both 424 object missing as ByRef argument type mismatch.
' Create dict
Dim dict As Scripting.Dictionary
' Create dictValues
Dim dictValues As Scripting.Dictionary
Dim key As Object
' Add keys to dict
dict("producent") = "Bedrijfsnaam"
dict("fase") = "Fase"
dict("status") = "Status"
dict("versienummer") = "Wijziging"
dict("documentdatum") = "Datum"
dict("omschrijving1") = "Omschrijving 1"
dict("omschrijving2") = "Omschrijving 2"
dict("omschrijving3") = "Omschrijving 3"
dict("discipline") = "Discipline"
dict("bouwdeel") = "Bouwdeel"
dict("labels") = "Labels"
' store values of sheet Source 1
With Source1
' create second dictValues to store values for each key
Set dictValues = New Scripting.Dictionary
' loop through keys in dict, this line gives error 424
For Each key In dict.Keys
' use dict to pass right value to rngByHead sub
Call rngByHead(Target, dict(key))
' store value of cell to dictValues under same key
dictValues(key) = .Cells(cell.Row, rngCol).Value
Next key
End With
' set values to sheet Target
With Target
' loop through keys in dict
For Each key In dict.Keys
' use dict to pass value of key item to rngByHead sub
Call rngByHead(Target, key)
' set value of cell to dictValues
.Cells(cell.Row, rngCol).Value = dictValues(key)
Next key
End With
What am I doing wrong? I'm new to vba dictionary and can't figure this one out. Thanks for your help!
Try like this:
Dim dict As New Scripting.Dictionary
Dim dictValues As New Scripting.Dictionary
The keyword New initializes an object from type Scripting.Dicitionary. Without it, no new object is initialized, just an object of type Scripting.Dictionary is declared. This is called early binding in VBA. See a bit here - What is the difference between Early and Late Binding?
I fixed it! Posting the code here on Stackoverflow for future reference. It turned out to be very simple, my dictionary was working fine. The key or k variable was set as Variant or Object, so it didn't pass it's value correctly as String to the rngByHead sub. Converting the k to str as String did the trick.
'sub that finds head in a specified worksheet and sets rngCol variable
Sub rngByHead(Sheet As Worksheet, head As String)
'setting up dictionary
Dim dict As New Scripting.Dictionary
Dim dictValues As New Scripting.Dictionary
Dim k As Variant
Dim str As String
'create dictionary
Set dictValues = New Scripting.Dictionary
Set dict = New Scripting.Dictionary
'add keys to dict
dict("producent") = "Bedrijfsnaam"
dict("fase") = "Fase"
dict("status") = "Status"
dict("versienummer") = "Wijziging"
dict("documentdatum") = "Datum"
dict("omschrijving1") = "Omschrijving"
dict("omschrijving2") = "Omschrijving 2"
dict("omschrijving3") = "Omschrijving 3"
dict("discipline") = "Discipline"
dict("bouwdeel") = "Bouwdeel"
dict("labels") = "Labels"
'store values of sheet Source 1
With Source1
'find and set variables using dictionary
'creating array of keys
keys = dict.keys
For Each k In keys
Call rngByHead(Source1, dict(k))
dictValues(k) = .Cells(docSource1.Row, rngCol).Value
Next
End With
With Target
'find and write variables using dictionary
For Each k In keys
'converting k as Variant to str as String
str = k
Call rngByHead(Target, str)
.Cells(cell.Row, rngCol).Value = dictValues(k)
Next
End With
Another note: you have to enable Microsoft Scripting Runtime in microsoft visual basic code editor under Tools > References.
Provided a user has enabled the option Trust Access to the VBA Project object model in File -> Options -> Trust Center -> Trust Center Setttings -> Macro Settings. You can run this code and enable the Microsoft Scripting Runtime reference:
Sub Test()
Dim Ref As Object, CheckRefEnabled%
CheckRefEnabled = 0
With ThisWorkbook
For Each Ref In .VBProject.References
If Ref.Name = "Scripting" Then
CheckRefEnabled = 1
Exit For
End If
Next Ref
If CheckRefEnabled = 0 Then
.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0
End If
End With
End Sub

Problems calling Function with Argument (Need to pass File name from one function to another) Excel VBA

I am trying to integrate 2 functions.
I have one sub function which works to loop through all files one by one.
once it has identified the file name.
It should call the function to run, on the opened file.
I can not seem to find a way to pass this on,
I did some reading on calling functions with arguments but when i try this i get a "compile error seperate list or )"
Can you please point me in the right direction?
I have posted the code below:
Option Explicit
Option Base 1
Public Const DATASHEET As String = "MDFDATA"
Public Const TABLECONVERSIONSHEET As String = "TABLECONVERSION"
Public Const OPTIONSSHEET As String = "OPTIONS"
Public Const FinalSheet As String = "Final Sheet"
Public lByte_Order As Long 'byte order
Public lData_Groups As Long 'number of data groups
Public lChannel_Groups As Long 'number of channel groups
Public lChannels As Long 'number of channels
Public lTable_offset As Long 'row offset for the conversion table sheet
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
Dim sFile_Name As String 'MDF file name
Dim lFile_Number As Long 'file number
MyFolder = "C:\Users\Documents\Test"
sFile_Name = Dir(MyFolder & "\*.dat")
Do While sFile_Name <> ""
lFile_Number = FreeFile
Open sFile_Name For Binary Access Read Shared As lFile_Number
Call PARSE_MDF
Loop
End Sub
'==================================================================================================
' PARSE_MDF
' Main function
' Returns True if successful
'==================================================================================================
Function PARSE_MDF() As Boolean
Dim sFile_Name As String 'MDF file name
Dim lFile_Number As Long 'file number
Dim lData_Groups_Counter As Long 'data groups counter
Dim lChannel_Groups_Counter As Long 'channel groups counter
Dim lChannels_Counter As Long 'channels counter
Dim lRecords As Long 'number of records in data block
Dim lRecord_Length As Long 'length of record in data block
Dim lData_Group_Address As Long 'data group address
Dim lData_Address As Long 'data address
Dim lChannel_Group_Address As Long 'Channel group address
Dim lChannel_Address As Long 'Channel address
Dim byCol As Byte 'column counter for output
Dim wsData_Sheet As Worksheet 'main worksheet
Dim wsTable_Conversion_Sheet As Worksheet
Dim rFirst_Signal As Range 'first signal in channel group
Dim rLast_Signal As Range 'last signal in channel group
Dim rSignals As Range 'range of signal names for a channel group
Application.EnableEvents = False
lTable_offset = 0
Set wsTable_Conversion_Sheet = Workbooks(ActiveWorkbook.Name).Worksheets(TABLECONVERSIONSHEET)
Set wsData_Sheet = Workbooks(ActiveWorkbook.Name).Worksheets(DATASHEET)
'file selected
If sFile_Name <> "False" Then
'clear old data
wsData_Sheet.Columns.Clear
wsTable_Conversion_Sheet.Columns.ClearContents
'set headers
wsData_Sheet.Cells(1, 1).Value = "Signal name"
wsData_Sheet.Cells(2, 1).Value = "Data type"
wsData_Sheet.Cells(3, 1).Value = "Lsb"
wsData_Sheet.Cells(4, 1).Value = "Offset"
wsData_Sheet.Cells(5, 1).Value = "Bit length"
wsData_Sheet.Cells(6, 1).Value = "Formula ID"
wsData_Sheet.Cells(7, 1).Value = "Formula"
wsData_Sheet.Cells(8, 1).Value = "First Bit position"
wsData_Sheet.Cells(9, 1).Value = "Table length"
wsData_Sheet.Cells(10, 1).Value = "Start Row"
'offset columns because of headers
byCol = 2
'get file number
lFile_Number = FreeFile
'open file
'check file integrity
If IDBLOCK(lFile_Number) Then
'check data exists
If HDBLOCK(lFile_Number, lData_Group_Address) Then
'main iteration for data groups
For lData_Groups_Counter = 1 To lData_Groups
'check channel group exists
If DGBLOCK(lFile_Number, lData_Group_Address, lChannel_Group_Address, lData_Address) Then
'channel group iteration
For lChannel_Groups_Counter = 1 To lChannel_Groups
'get channel group data
Call CGBLOCK(lFile_Number, lChannel_Group_Address, lChannel_Address, lRecord_Length, lRecords)
'set the first signal range in this channel group
Set rFirst_Signal = wsData_Sheet.Cells(1, byCol)
'channels iteration
For lChannels_Counter = 1 To lChannels
'get channel data for each channel
Call CNBLOCK(lFile_Number, lChannel_Address, wsData_Sheet, byCol)
'excel fudge
If byCol <> 255 Then
byCol = byCol + 1
End If
Next 'lChannels_Counter
'set the last signal range in this channel group
Set rLast_Signal = wsData_Sheet.Cells(1, byCol - 1)
'format divider columns
wsData_Sheet.Columns(byCol).ColumnWidth = 5
wsData_Sheet.Columns(byCol).Interior.ColorIndex = 0
wsData_Sheet.Columns(byCol).Interior.Pattern = xlLightUp
wsData_Sheet.Columns(byCol).Interior.PatternColorIndex = xlAutomatic
'excel fudge
If byCol <> 255 Then
'for space between channels
byCol = byCol + 1
End If
Next 'lChannel_Groups_Counter
'get range of signals to get data for
Set rSignals = wsData_Sheet.Range(rFirst_Signal, rLast_Signal)
'get signal data
'no channel data in this data group
Else
PARSE_MDF = False
End If
Next 'lData_Groups_Counter
'no data in MDF file
Else
PARSE_MDF = False
End If
'not a MDF file
Else
PARSE_MDF = False
End If
'close file
Close #lFile_Number
'tidy up sheet
wsData_Sheet.Rows.EntireRow.AutoFit
wsData_Sheet.Columns.EntireColumn.AutoFit
wsData_Sheet.Rows("2:15").EntireRow.Delete
wsData_Sheet.Columns("A:A").EntireColumn.Delete
wsData_Sheet.Cells.HorizontalAlignment = xlCenter
'function ends normally
PARSE_MDF = True
'no file was selected
Else
PARSE_MDF = False
End If
Application.EnableEvents = True
End Function
What you need to do is to pass the found filename as argument to the function. Now your function does not have an argument to pass it on so first of all create one such for ex.
Function PARSE_MDF(ByVal myFilePath as String) As Boolean
Then you need to change your loop to call the function correctly for ex.
Do While sFile_Name <> ""
....
myboolenvaluetohodthereturnvalue = PARSE_MDF(sFile_Name)
.... 'does your funtion need to return value and be tested?
sFile_Name = Dir() 'Call dir again without parameter to skip to next found file
Loop
Otherwise I haven't checked your code but this should get you started..

Resources