Optimize this?: String substitution function 1

[VBAjedi]

I just wrote the following function, but it seems a bit bulky for what it does. When you pass the function a string, a worksheet object, and a row number as arguments, it looks for embedded flags in the string that consist of the "&" character followed by a column letter (ex "&A&quot. For each valid flag it finds, it replaces the flag in the string with the contents of the cell specified by the flag's column letter and the row number passed to the function. Clear as mud?

If someone could help me optimize this, I'd sure appreciate it!

Function MergeColVals(TemplateString As String, DataSheet As Worksheet, DataRow As Integer)
Dim x, y, a
Dim MkrPos
Dim TmpStr$, FieldVal$, ColLtr$
Dim LeftString$, RightString$

x = 1
TmpStr = TemplateString
Do While x < Len(TmpStr) And x > 0
   MkrPos = InStr(x, TmpStr, &quot;&&quot;)
   If Not MkrPos = 0 Then ' & character found at pos. MkrPos
      ' Extract flag's column letter, get field value if flag valid
      x = MkrPos + 1 ' On next loop, look for & starting at following character
      ColLtr = &quot;&quot;
      For y = 1 To 2 ' Possible columns from &quot;A&quot; to &quot;IV&quot;
         a = UCase(Mid(TmpStr, MkrPos + y, 1)) ' Ucase adjusts for $Ab, etc.
         Select Case a
         Case &quot;A&quot; To &quot;Z&quot;
            ColLtr = ColLtr & a
         Case Else
            Exit For ' space or punctuation marks end of flag
         End Select
      Next y
      If Len(ColLtr) > 0 Then ' Valid marker found
         FieldVal = DataSheet.Range(ColLtr & DataRow).Value
         FlagLength = Len(ColLtr) + 1 ' account for & too. . .
      Else
         FieldVal = &quot;&quot;
         FlagLength = 0 ' Leave & intact, it's not a flag
      End If
      LeftString = Left(TmpStr, (MkrPos - 1))
      RightString = Right(TmpStr, Len(TmpStr) - (MkrPos - 1 + FlagLength))
      TmpStr = LeftString & FieldVal & RightString
   Else
      x = 0 ' no more & characters in string
   End If
Loop

MergeColVals = TmpStr

End Function

Sub TestFunct()
' Put test values in Sheet1 cells A8 and AA8
Dim x
x = MergeColVals(&quot;Simple &A Test & Value &aa.&quot;, Sheet1, 8)
MsgBox x
End Sub

Thanks,


VBAjedi

 

[combo]

With VBA 6 (office 2k and above):

[tt]Function abc(TemplateString As String, DataSheet As Worksheet, DataRow As Integer)
Dim spString, spStringItem, spStringItemLength
dim Test As Boolean
spString = Split(TemplateString, " &quot
For i = 0 To UBound(spString)
spStringItem = spString(i)
spStringItemLength = Len(spStringItem)
If spStringItemLength > 1 And spStringItemLength < 4 And Asc(spStringItem) = 38 Then
' test column name here, get ColLtr and Test as boolean
If Test Then
spString(i) = DataSheet.Range(ColLtr & DataRow).Value 'replace here
End If
End If
Next i
abc = Join(spString, &quot; &quot
End Function[/tt]

combo

 

[combo]

To validate column name and dispath code flow, an error handler can be used:

[tt]Function MergeColVals(TemplateString As String, DataSheet As Worksheet, DataRow As Integer)
Dim spString, spStringItem, spStringItemLength
spString = Split(TemplateString, &quot; &quot
For i = 0 To UBound(spString)
spStringItem = spString(i)
spStringItemLength = Len(spStringItem)
If spStringItemLength > 1 And spStringItemLength < 4 And Asc(spStringItem) = 38 Then
On Error GoTo errH
With DataSheet
spString(i) = &quot;&quot; & Intersect(.Columns(Right(spStringItem, spStringItemLength - 1)), .Rows(DataRow)).Value
End With
errH:
On Error GoTo 0
End If
Next i
MergeColVals = Join(spString, &quot; &quot
End Function[/tt]

combo

 

[VBAjedi]

Nice, Combo! Split/Join would definitely make it easier. . . unfortunately, I need to keep my code compatible with XL97 forward(yes, XL97 is very much alive and kicking in my office environment. . .). Also, I have no guarantee that my users will preface the &quot;&&quot; flag indicator with a space or any other predictable character.

Well, if I'm stuck with my version, so be it. It works, and it isn't too slow (although I may change my mind about that when I call it 500x in a row!).

A star for your suggestions - the method will be put to use as soon as I'm in a place to use the new functions in VB6.

Thanks again!

VBAjedi