PDA

View Full Version : Solved: Several issues with my code



mae0429
06-05-2008, 09:44 AM
Hi, I'm new to the forum and I'm looking for some help. I have a decent background in other programming languages but am new to VBA. I've done alright so far, but now I'm stuck.

I need help splitting up a string that is passed to a function. This string comes from a listbox. Then, the split up parts must be put into an array (or something) and then those individual strings need to be searched for on the worksheet. When the cell is found, it needs to be added to a range that gets returned from the function.

Here is my code so far:



Private Sub EnterButton_Click()
' Call header selecting function
myHeadings = SelectHeadings
Unload Me

' Call range finder function
HeaderRange = FindHeader(myHeadings)

End Sub


Function SelectHeadings() As String
Dim lItem As Long
Dim headings As String
For lItem = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(lItem) = True Then
headings = headings & ListBox1.List(lItem) & ","
ListBox1.Selected(lItem) = False
End If
Next
headings = Left(headings, Len(headings) - 1)
SelectHeadings = headings
MsgBox ("Your selections have been saved!")
End Function


Function FindHeader(headerStr) As Range
' Split up header string
Dim s() As String
Dim i As Integer

s = Split(headerStr, ",")
For i = 0 To UBound(s)
s(i) = Trim(s(i)) & ","
Next
' Loop through string array finding corresponding cells
Dim foundRange() As Range
With Worksheets(1)
For i = 0 To UBound(s)
Set c = .Find(s(i), LookIn:=xlValues)
foundRange(i) = c
Next i
End With
FindHeader = foundRange
End Function

Bob Phillips
06-05-2008, 10:01 AM
Not tested, but this looks about right




Function FindHeader(headerStr) As Range
' Split up header string
Dim s() As String
Dim i As Long

s = Split(headerStr, ",")
For i = LBound(s) To UBound(s)
s(i) = Trim(s(i)) & ","
Next
' Loop through string array finding corresponding cells
Dim foundRange As Range
With Worksheets(1).Cells
For i = LBound(s) To UBound(s)
Set c = .Find(s(i), LookIn:=xlValues)
If Not c Is Nothing Then

If foundRange Is Nothing Then

Set foundRange = c
Else

Set foundRange = Union(foundRange, c)
End If
End If
Next i
End With
FindHeader = foundRange
End Function

mae0429
06-05-2008, 10:17 AM
First of all, thank you for the help! However, I replaced the code and was met with "Run-time error '91': Object variable or With block variable not set" and when I click Debug, it highlights the "HeaderRange = FindHeader(myHeadings)" line. Any further suggestion as to what went wrong?

mdmackillop
06-05-2008, 10:58 AM
try

Set FindHeader = foundRange

mae0429
06-05-2008, 11:32 AM
Still no luck :(

Let me start at the beginning and maybe that will put it more in perspective (or there could be an easier way to do what I'm trying to do).

I'm looking to automate a very tedious manual process that needs to have versatility in choosing certain columns of data. The data comes in a .txt file and is separated by vertical bars (|). It needs to be imported to excel, then certain columns must be selected, then it should be cleaned up (borders, bold text, etc.) I decided to create a user form that has three buttons: Import, Select and Format, and Close.

Here is the module that starts us off:

Sub Produce_CAPA_Status_Report()
'
' Button Form macro
ButtonForm.Show
End Sub


Then, here is the code on that form:

Private Sub CloseButton_Click()
' Close dialog box
Unload Me
End Sub

Private Sub ImportButton_Click()
' Call import function
ImportTxt
End Sub

Private Sub ListButton_Click()
' Open listbox
ListForm.Show
End Sub

Function ImportTxt()
'Get file to import and delimit it appropriately
fileLookup = Application _
.GetOpenFilename("Text Files (*.txt), *.txt")
Dim fileToOpen As String
fileToOpen = "TEXT;" & fileLookup
With ActiveSheet.QueryTables.Add(Connection:=fileToOpen, Destination:=Range("A1"))
.Name = "RawData"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Function
Function HeaderRange() As Range
' Get the number of headings
nextcounter = 0
For i = 1 To 10
counter = 0
For j = 1 To 100
cellCheck = Cells(i, j)
If Not cellCheck = "" Then
counter = counter + 1
Else
Exit For
End If
Next j
If counter > nextcounter Then
nextcounter = counter
End If
Next i

' Get the starting row number
For k = 1 To 100
cellStart = Cells(k, 2)
If Not cellStart = "" Then
startRow = k
Exit For
End If
Next k
Range(Cells(startRow, 1), Cells(startRow, nextcounter)).Name = "MyRange"
HeaderRange = "MyRange"
End Function


Next, when it calls the list form (which consists of a listbox and an enter button), we get the following:

Private Sub EnterButton_Click()
' Call header selecting function
myHeadings = SelectHeadings
Unload Me

' Call range finder function
HeaderRange = FindHeader(myHeadings)
' Format report
FormatStatusReport (HeaderRange)

End Sub

Private Sub UserForm_Initialize()
Dim rCell As Range
With ListBox1
For Each rCell In Range("MyRange")
Dim cellname As String
cellname = rCell.Value
ListBox1.AddItem cellname
Next rCell
End With
End Sub

Function SelectHeadings() As String
Dim lItem As Long
Dim headings As String
For lItem = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(lItem) = True Then
headings = headings & ListBox1.List(lItem) & ","
ListBox1.Selected(lItem) = False
End If
Next
headings = Left(headings, Len(headings) - 1)
SelectHeadings = headings
MsgBox ("Your selections have been saved!")
End Function

Function FindHeader(headerStr) As Range
' Split up header string
Dim s() As String
Dim i As Long

s = Split(headerStr, ",")
For i = LBound(s) To UBound(s)
s(i) = Trim(s(i)) & ","
Next
' Loop through string array finding corresponding cells
Dim foundRange As Range
With Worksheets(1).Cells
For i = LBound(s) To UBound(s)
Set c = .Find(s(i), LookIn:=xlValues)
If Not c Is Nothing Then

If foundRange Is Nothing Then

Set foundRange = c
Else

Set foundRange = Union(foundRange, c)
End If
End If
Next i
End With
Set FindHeader = foundRange
End Function

Function FormatStatusReport(myCells As Range)
' Formatting code goes here
End Function

Bob Phillips
06-05-2008, 11:41 AM
Got a sample text file as well?

mae0429
06-05-2008, 11:56 AM
Sorry, here's a sample text file.

mdmackillop
06-05-2008, 03:07 PM
Functions moved to Module
Comma deleted from s(i) values

mae0429
06-06-2008, 09:05 AM
For some reason, it still didn't work, but when I removed it from being a function and just stuck it in my list form code under the commandbutton_click() sub, it worked.

Thank you all for your help!

mdmackillop
06-06-2008, 09:16 AM
Glad it worked out. For some reason, the Function would not run on the UserForm, which is why I moved it.