Close Window   
Free Ebook
Got an Excel Question?
Ask it in our Excel forum!
TeachExcel.com
Subscribe for Free Excel tips & more!
E-mail:
Advertisements



Find First Lower Case Letter In String - Vba Conumdrum!

Forum Register
Search Excel Forum Posts, Tutorials, Macros, Tips, and More

Hi,

I'm having a nightmare with a VBA problem and wondered if any geniusses out there would be able to help me! Basically I want to compare 2 lists of names from different sources but both are in different formats. One list has the format: First name, Last Name (e.g. Peter Stevens) the other list is in the format LAST NAME, First Name (e.g. STEVENS Peter). There are some people in the list with double barrelled surnames (e.g. SMITH JONES) so I cant use the space character as a separator. The only way I can see of separating the two would be to locate the first occurance of a lowercase letter in the second List. Once I've found the character number in the string I can separate the two names out into the correct format of: First Name, Last Name using the Instr method.

I've written the code below to try and find it but I cant get it to work, the loop just goes all the way through the string and never finds a match. Any pointers would be really appreciated! Thanks

Code:

Option Explicit
Option Compare Binary
 
Sub Test1()
 
Dim StrLen As Integer
Dim ChrNum As Integer
Dim i As Integer
Dim j As Integer
Dim Exitfor As Boolean
Dim str As String
Dim SearchChar As String
 
StrLen = Len(Selection)
str = Selection.Value
For i = 1 To StrLen
 
    Exitfor = False
    For j = 97 To 122 '97-122 lower case ASCII charachers
 
        SearchChar = Chr(j)
        If InStr(i, str, SearchChar, vbBinaryCompare) = 1 Then
            Exitfor = True ' if this equals true the exit loop
            Exit For
        End If
    Next j
 
    If Exitfor = True Then Exit For
 
Next i
 
MsgBox i ' msgbox to return character number of first lower case letter in 
string
 
End Sub




View Answers     

Similar Excel Tutorials

Make All Text Upper Case or Lower Case in Excel
How to quickly change all text to upper case or lower case in Excel. This allows you to change the case of text wi ...
Count the Number of Cells that Contain Specific Text in Excel
How to count the number of cells that contain specific text within a spreadsheet in Excel. I'll show you how to cou ...
Count the Number of Cells that Start or End with Specific Text in Excel
How to count cells that match text at the start or the end of a string in Excel. If you want a fuller explanation o ...
Capitalize First Letter of Every Word in a Cell - PROPER Function
In Excel you can use a function to capitalize the first letter of every word in a cell. This allows you to prepare ...

Helpful Excel Macros

Vlookup Macro to Return All Matching Results from a Sheet in Excel
- This Excel Macro works like a better Vlookup function because it returns ALL of the matching results. Run the
Complete Guide to Printing in Excel Macros - PrintOut Method in Excel
- This free Excel macro illustrates all of the possible parameters and arguments that you can include in the PrintOut Meth
Enter Text/Characters with a Double-Click of the Mouse
- This macro allows you to enter any text or number, that you specify, in a cell on which you double-click. In the exampl
Capitalize the First Letter of Every Word in a Cell
- This macro will make the text of any selected cell in excel proper case. This means that the first letter of any word in
Save the Current Worksheet as a New Excel Workbook File
- This Excel Macro will save the currently visible/active worksheet (the one that you see when you run the macro) to a

Similar Topics







Hello,

I need help with the dynamic range names created programmatically.

Follwing code generates the range names! When I tries to refer them as
"workbook.xls"!"rangename" I get error message 'refence is not valid' !

I am unable to figure this! I need to use all these range names in charts,
which I intend to create programmatically.

Thanks

Mike

Sub DynamicRangeNames()

Dim intRow_Num As Integer
Dim strRangeName As String
Dim ch As ChartObject, x
Dim SearchString, SearchChar, MyPos As Integer
Dim strSheetName As String, strCoverSheet As String
Dim strSheetNameNew As String
Dim isheet As Integer, i As Integer, j As Integer
Dim iRowNum As Integer, iColNum As Integer
Dim iReportRowNum As Integer, iReportColNum As Integer
Dim strMonthName As String, strPrevMonthName As String
Dim imonth As Integer, intNewGroup As Integer
Dim strYearname As String, strReportName As String


For i = 1 To ActiveWorkbook.Sheets.Count

strSheetName = ActiveWorkbook.Sheets(i).Name
strSheetNameNew = strSheetName
intNewGroup = 4
Select Case strSheetName

Case "Cover Sheet", "Template", "Old Template", "Charts"
'Do nothing, ignore this worksheets
Case Else

For intRow_Num = 3 To 36
If IsEmpty(Sheets(strSheetName).Cells(intRow_Num,
1)) Then
intNewGroup = intRow_Num + 1
intRow_Num = intRow_Num + 1
Else
intRow_Num =
Sheets(strSheetName).Cells(intRow_Num, 1).Row
strRangeName =
Trim(Sheets(strSheetName).Cells(1, 1).Value) & "_" & _
Trim(Sheets(strSheetName).Cells(intNewGroup,
1).Value) & _
"_" &
Trim(Sheets(strSheetName).Cells(intRow_Num, 1).Value)
Do
MyPos = InStr(1, strRangeName, " ",
vbBinaryCompare)
If MyPos > 0 Then
Mid(strRangeName, MyPos, 1) = "_"
End If
Loop Until MyPos <= 0

Do
MyPos = InStr(1, strRangeName, "-",
vbBinaryCompare)
If MyPos > 0 Then
Mid(strRangeName, MyPos, 1) = "_"
End If
Loop Until MyPos <= 0

Do
MyPos = InStr(1, strSheetNameNew, " ",
vbBinaryCompare)
If MyPos > 0 Then
Mid(strSheetNameNew, MyPos, 1) = "_"
End If
Loop Until MyPos <= 0

Do
MyPos = InStr(1, strSheetNameNew, "-",
vbBinaryCompare)
If MyPos > 0 Then
Mid(strSheetNameNew, MyPos, 1) = "_"
End If
Loop Until MyPos <= 0
ActiveWorkbook.Names.Add Name:=strRangeName,
RefersTo:= _
"=OFFSET(" & strSheetNameNew & "!" &
Sheets(strSheetName).Cells(intRow_Num, 1).Address & _
",0,1,,COUNTA(" & strSheetName & "!$" & _
intRow_Num & ":$" & intRow_Num & ")-1)"
End If
Next
End Select
Next

End Sub





This code is a little complicated to explain. Basically, I am just wondering if anyone can point out any syntax errors. The code will not execute. The "Dyn_Sequence" is just a string that is "CTTTCTTTC0". I'm trying to create a while loop that will step through the string and execute case commands based on what is in the string. "seq_ptr" is just a pointer that points to a certain character in the string. The while loop keeps going until the "seq_ptr" hits the value "0." At this point I know it is the end of my string and I can stop executing Case Commands. By the way, I just used a while loop because I am more comfortable with them. If there is a way to use a for loop and have it go until it reaches the length of the string then I could do that too.

Code:

Dim sequence(0 To 15)
Dim seq_ptr As Integer
Dim seq As Integer
Dim c_offset As Integer
Dim t_offset As Integer


While seq_ptr + 1  0
    seq = 0
    If Mid(Dyn_Sequence, seq_ptr, 3) = "CTC" Then
        seq = 1
    End If
    If Mid(Dyn_Sequence, seq_ptr, 4) = "CTTC" Then
        seq = 2
    End If
    If Mid(Dyn_Sequence, seq_ptr, 5) = "CTTTC" Then
        seq = 3
    End If
    Select Case (seq)
        Case (0)
        MsgBox ("Not a valid test sequence")
        Exit Sub
        Case (1)
        r(t_offset) = t(t_offset) / ((c(c_offset) + c(1 + c_offset)) / 2)
        seq_ptr = seq_ptr + 2
        t_offset = t_offset + 1

        Case (2)
        r(t_offset) = t(t_offset) / (((2 * c(c_offset)) + c(1 + c_offset)) / 3)
        r(1 + t_offset) = t(1 + t_offset) / ((c(c_offset) + (2 * c(1 + c_offset))) / 3)
        seq_ptr = seq_ptr + 3
        t_offset = t_offset + 2
        
        Case (3)
        r(t_offset) = t(t_offset) / (((3 * c(c_offset)) + c(1 + c_offset)) / 4)
        r(1 + t_offset) = t(1 + t_offset) / ((c(c_offset) + c(1 + c_offset)) / 2)
        r(2 + t_offset) = t(2 + t_offset) / ((c(c_offset) + (3 * c(1 + c_offset))) / 4)
        seq_ptr = seq_ptr + 4
        t_offset = t_offset + 3
    End Select
    c_offset = c_offset + 1
Wend





I have some text in cell C2 that looks like this: clonidine_Area
I want to copy the text before the underscore and paste it to another cell.

I've gotten this far but don't know how to proceed... How do I use the position number to selectively copy the string that I want? Any help would be greatly appreciated.


Sub Cp()

Dim SearchString, SearchChar, MyPos

SearchString = ActiveSheet.Range("C2")
SearchChar = "_"

MyPos = InStr(1, SearchString, SearchChar, 1)



End Sub


Hi,

I am trying to create a table (two-dimensional array actually) that has in first column (or dimension) a number that represents a position in a string and in second column whether that position in a string is a starting tag (1) or an ending tag (2).

To give you first an example, let's take string "http://www.mrexcel.com/forum/newthread.php?do=newthread&f=10", where we could say the starting tag is "a" and ending tag is "e". In other words, the result should be

14 2
17 2
31 2
36 2
37 1
48 2
53 2
54 1

Now, I thought to do this so that I save first the string I process as sItem and as sOrigItem, then begin to process the string from the start of the string, find both next starting and ending tag (in this example those are 14 and 37) and then compare those numbers to each other and add smaller (here, 14) to the array as the cell(i,1), where i of course represents the row. After that, I cut the string with "Right(item, Len(item) - InStr(1, item, sAlkuTagi))" and then loop that until... what? Until it gives an error or how do I check there's no more starting or ending tags?

Ok, then the solution I have so far as a code

Code:

Sub SplitTest()
    Dim item As String
    Dim aiTL() As Integer 'Tag locations
    Dim sOrigItem As String 'The original string
    Dim iNST As Integer 'Next starting tag
    Dim iNET As Integer 'Next ending tag
    
    Dim sSTag As String 'Starting tag
    Dim sETag As String 'Ending tag
    Dim i As Integer 'Keeps count of tags
    
    sOrigItem = "http://www.mrexcel.com/forum/newthread.php?do=newthread&f=10"
    item = sOrigItem
    
    sSTag = "a"
    sETag = "i"
    
    If sSTag = sETag Then
        MsgBox "Starting and ending tag can't be the same!"
        Exit Sub
    End If
    
    i = 1
    
    Do Until (InStr(1, item, sSTag) = 0) And (InStr(1, item, sETag) = 0) 'Is this the right way to check when the loop is done?
    'This array has two dimensions. One tells where the tag is, 
    'other whether it is a starting tag (1) or an ending tag (2).
        ReDim Preserve aiTL(1 To i, 1 To 2)
        iNST = InStr(1, item, sSTag)
        iNET = InStr(1, item, sETag)
        
        If i > 1 Then
            If iNST < iNET Then 'Next found tag is a starting tag
                aiTL(i, 1) = aiTL(i - 1, 1) + InStr(1, item, sSTag)
                aiTL(i, 2) = 1 'So this is marked as a starting tag
            ElseIf iNET < iNST Then 'Next found tag is an ending tag
                aiTL(i, 1) = aiTL(i - 1, 1) + InStr(1, item, sETag)
                aiTL(i, 2) = 2 'So this is marked as a ending tag
            Else
                MsgBox "Some unknown error (The next tag is neither starting nor ending tag)"
                Exit Sub
            End If
        Else 'Needs an if-clause so that it wouldn't point over the begin of array ie. to row 0
            If iNST < iNET Then
                aiTL(i, 1) = aiTL(i, 1) + InStr(1, item, sSTag)
                aiTL(i, 2) = 1
            ElseIf iNET < iNST Then
                aiTL(i, 1) = aiTL(i, 1) + InStr(1, item, sETag)
                aiTL(i, 2) = 2
            Else
                MsgBox "Some unknown error (The next tag is neither starting nor ending tag)"
                Exit Sub
            End If
        End If
        
        'Calculates the remaining string
        item = Right(item, Len(item) - InStr(1, item, sSTag))
        i = i + 1
    Loop
    
End Sub


So the two questions I have
1) How do I code in the ending condition
2) Why does this code now subscript out of range error in that "redim preserve..." row?


Hi all,

I have a listbox, a text input field and an add button.

When a user enters a string into input field and hits add, i want that string to appear as a new entry in the list box. Code I have so far (in its entirety):

Code:

Private Sub add_agent_Click()
    '1 - check it name already exists or not
    '2 - fix up first letter of each name to uppercase
    '3 - make sure there is a space (indicating two names)
    '4 - add to list
    
    Dim agent_sheet As Worksheet
    Set agent_sheet = Worksheets("agents")
    
    Dim new_agent As String
    new_agent = Trim(control_panel_form.agent_name.value)
    
    If InStr(1, new_agent, " ") = 0 Then
        MsgBox "Please enter first name and last name"
        Exit Sub
    End If
    
    Dim i As Integer
    
    For i = 1 To xlLastRow(agent_sheet.Name)
        If new_agent = agent_sheet.Range("C" & i) Then
            MsgBox new_agent & " already exists!"
            Exit Sub
        End If
    Next
    
    control_panel_form.agent_list.AddItem new_agent
    Unload control_panel_form
    Load control_panel_form
    control_panel_form.Show

    MsgBox new_agent
    
End Sub


But obviously this is not working!


Can anyone help out?


This is a loop previously set up for extracting the capitalised words from a string and displaying them in messageboxes, but it seems to only output the last name in the list in my situation.
I've tried various of modifications to the strings it checks for, I don't understand why it won't isolate the other names.


Code:

Sub SurnameIsolator()
Dim ChrUString As String
Dim Start As Integer
Dim Finish As Integer
ChrUString = "Alan BUNNY / Peter THOMPSON / Sarah HINKLEY"
Start = 1
Do While Finish <> InStrRev(ChrUString, " ")
    Finish = InStr(Start + 1, ChrUString, " ")
    If Mid(ChrUString, Start, Finish - Start) = UCase(Mid(ChrUString, Start, Finish - Start)) Then If InStr(ChrUString, " ") = 0 Then MsgBox Mid(ChrUString, Start, Finish - Start)
    Start = InStr(Finish, ChrUString, " ")
Loop
If Right(ChrUString, Len(ChrUString) - InStrRev(ChrUString, " ")) = UCase(Right(ChrUString, Len(ChrUString) - InStrRev(ChrUString, " "))) Then MsgBox Right(ChrUString, Len(ChrUString) - InStrRev(ChrUString, " "))
End Sub





Hi All,

I have to write a sub that compares the password that I put in an input box to range of passwords (1000 in all) in column A. if there is a duplicate it should display a message asking to enter a new password . here is the code that I have written .... cant seem to figure out the mistake....

thanks for your help.....

' Example 6 page 103 Chapter 7 Christian Albright VBA for Modelers

Sub newPassword2()

Dim newPass As String, valid As Boolean, i As Integer, newPass2 As String, oldPassword As Range, MyCount As Integer, noldPass As String
Dim res As Boolean
With Range("a1")

Range(.Offset(0, 0), .End(xlDown)).Name = "noldPass"
Set oldPassword = Range("noldPass")
End With

MyCount = Application.CountA(oldPassword)

MsgBox "Oldpassword has " & MyCount & " passwords"

valid = False
' This do loop will check if you have entered the correct password
Do Until valid
newPass = InputBox("Please enter your new password consisting of uppercase letters & digits")
If vbCancel Then Exit Sub
'this loop check for the conditions of the new password.
'If Len(newPass) > 8 And newPass UCase(newPass) Then
'Use or so that if anything is true it will ask you to re- enter
If newPass UCase(newPass) Or InStr(newPass, " ") 0 Then
MsgBox "The password has to be upper case and only digits no spaces" & _
" re-enter", vbInformation, "Re-enter the Password"

res = Application.WorksheetFunction.Match(newPass, oldPassword, 0)

If IsError(res) = True Then
MsgBox "This password has been selected, select a new Password", vbInformation, "Duplicate Password"

Else
valid = True
MsgBox " Congratulations you entered a new Password"
Range("a1").Offset(MyCount, 0) = newPass

End If
End If

Loop
en d Sub
P.S - Some of the formatting is screwed up


Hello,

My question is about converting a Literal String to Character Code.

Here's why. I'm using the following coded InputBox. And it prompts the user for what characters to search for in a string.

Code:

Sub FindChar()

    CharToFind = InputBox("Please enter char to search for")

    Result = InStr(1, Text, CharToFind, 1)

    If Result <> 0 Then
       MsgBox "The char was found in the text at character number " & Result
    Else
       MsgBox "The char was not found."
    End If
End Sub


The above code works great if I enter a letter or an integer. But I need to allow the user to enter carriage returns in ANSI code, such as Chr(13).

As of now, if the user enters "Chr(13)" then the CharToFind variable actually contains the literal string in quotes, not the character code without the quotes. So that the final search string is essentially what's shown below:

Code:

Result = InStr(1, Text, "Chr(13)", 1) ' with quotes

' When what i want it to represent is:
Result = InStr(1, Text, Chr(13), 1) ' without quotes


So my question is, how do i convert the variable CharToFind's value of "Chr(13)" to a value of Chr(13)?

Is there a common way of doing this? A function, perhaps, that does this sort of conversion? I would be grateful for some direction in my dilemma.

Thanks for any and all help!


Function Format_Code128 (InString As String) As String
Dim Sum As Integer, i As Integer
Dim Checksum As Integer, Checkchar As Integer
Dim MyString As String, CVal As Integer

' Initialize running total with value of
' Subset B start character

Sum = 104

' Scan the string and add character value times position

For i = 1 To Len(InString)

' Copy one character from InString position i to MyString

MyString = Mid$(InString, i, 1)

' Get the numeric value of the character and subtract
' 32 to shift (the space character, ASCII value 32, has
' a numeric value of 0 as far as Code 128 is concerned)

CVal = Asc(MyString) - 32

' Add the weighted value into the running sum

Sum = Sum + (CVal * i)
Next i

' Calculate the Modulo 103 checksum

Checksum = Sum Mod 103

' Now convert this number to a character.

If Checkdigit = 0 Then
Checkchar = 174
ElseIf Checkdigit < 94 Then
Checkchar = Checkdigit + 32
Else
Checkchar = Checkdigit + 71
End If

' Now format the final output string: start character,
' data, check character, and stop character

MyString = Chr(162) + InString + Chr(Checkchar) + Chr(164)
Format_Code128 = MyString
End Function

Hi,

I have code above User Define funtion in Excel and converted my data
(example CCF001257) into code 128 B of Barcode symbology..the UDF returns
value as
¢CCF001257®¤ but when in change it into code 128 font with 20 font size the
scanner does not reads it.. where is the problem lies ...

Regards,

safi.





Function Format_Code128 (InString As String) As String
Dim Sum As Integer, i As Integer
Dim Checksum As Integer, Checkchar As Integer
Dim MyString As String, CVal As Integer


' Initialize running total with value of
' Subset B start character

Sum = 104

' Scan the string and add character value times position

For i = 1 To Len(InString)

' Copy one character from InString position i to MyString

MyString = Mid$(InString, i, 1)

' Get the numeric value of the character and subtract
' 32 to shift (the space character, ASCII value 32, has
' a numeric value of 0 as far as Code 128 is concerned)

CVal = Asc(MyString) - 32

' Add the weighted value into the running sum

Sum = Sum + (CVal * i)
Next i

' Calculate the Modulo 103 checksum

Checksum = Sum Mod 103

' Now convert this number to a character.

If Checkdigit = 0 Then
Checkchar = 174
ElseIf Checkdigit < 94 Then
Checkchar = Checkdigit + 32
Else
Checkchar = Checkdigit + 71
End If
'
' Now format the final output string: start character,
' data, check character, and stop character
'
MyString = Chr(162) + InString + Chr(Checkchar) + Chr(164)
Format_Code128 = MyString
End Function

I Have coded above UDF to construct data (my data is like "CCF001257") the
UDF returns value as

¢CCF001257®¤ but when I changed this into 128 font and took printout the
scanner is not reconging it..what will be the problem..will any one trace out
...i have a doubt..
1.code 128 and code 128 B fonts are different if so..
2. shall i have to use Code 128 B font

does this will slove..

Plz tell me soon...

Regards,

safi.




This formula decomposer parses a cell formula and splits it up in multiple rows with indents to make understanding a complex cell formula a bit easier.

I believe the output could be improved (not sure what would be more useful, but ...) so I submit it to the group wisdom.

Please review and make improvements where needed.
Code:

Sub FormulaDecomposer()

    Dim intX As Integer
    Dim booExists As Boolean
    Dim intNestCount As Integer
    Dim intNextRow As Integer
    Dim intOpen As Integer
    Dim intClose As Integer
    Dim strInput As String
    Dim intNextAscii As Integer
    
    For intX = 1 To Sheets.Count
        If Sheets(intX).Name = "Formula Decon" Then
            Range("A3").CurrentRegion.Cells.ClearContents
            booExists = True
            Exit For
        End If
    Next
    If Not booExists Then Worksheets.Add(Befo =Sheets(1)).Name = "Formula Decon"
    If Len(Trim(Worksheets("Formula Decon").Range("A1"))) = 0 Then
        strInput = InputBox("Enter Formula", "Enter", "()")
    Else
        strInput = Trim(Worksheets("Formula Decon").Range("A1"))
    End If
    
    intOpen = 0
    intClose = 0
    For intX = 1 To Len(strInput)
        If Mid(strInput, intX, 1) = "(" Then intOpen = intOpen + 1
        If Mid(strInput, intX, 1) = ")" Then intClose = intClose + 1
    Next
        
    If intOpen  intClose Then MsgBox "Unbalanced parenthesis.":                 Exit Sub
    If intOpen = 0 Then MsgBox "No parenthesis.": Exit Sub
    
    
    With Worksheets("Formula Decon")
        .[A1] = Chr(32) & strInput
        
        intNextRow = 3
        intNestCount = 0
        Do While Len(strInput) > 0
            intNextAscii = NextDelimiter(strInput)
            Select Case intNextAscii
            Case 40, 123, 91 'Open Parens - All up to and including ( into ready row, next column
                intNestCount = intNestCount + 1
                .Cells(intNextRow, intNestCount) = _
                    Chr(32) & Left(strInput, InStr(strInput, Chr(intNextAscii)))
                strInput = Mid(strInput, InStr(strInput, Chr(intNextAscii)) + 1)
            Case 41, 125, 93 'Close Parens - All up to and including ) in current row, current column 1 col left for next
                    intNestCount = intNestCount + 1
                    .Cells(intNextRow, intNestCount) = Chr(32) & Left(strInput, InStr(strInput, Chr(intNextAscii)) - 1)
                    intNestCount = intNestCount - 1
                    If Left(strInput, 1)  ")" Then intNextRow = intNextRow + 1
                    .Cells(intNextRow, intNestCount) = Chr(32) & Chr(intNextAscii)
                    strInput = Mid(strInput, InStr(strInput, Chr(intNextAscii)) + 1)
                    intNestCount = intNestCount - 1
            Case 44  'Comma - comma in same cell as was last written
'                If Right(.Cells(intNextRow, intNestCount).Offset(-1, 1).Value, 1) = ")" Then
'                    .Cells(intNextRow, intNestCount).Offset(-1, 1) = _
'                        .Cells(intNextRow, intNestCount).Offset(-1, 1) & _
'                        Left(strInput, InStr(strInput, Chr(intNextAscii)))
'                Else
                    .Cells(intNextRow, intNestCount) = .Cells(intNextRow, intNestCount) & _
                        Left(strInput, InStr(strInput, Chr(intNextAscii)))
                'End If
                strInput = Mid(strInput, InStr(strInput, Chr(intNextAscii)) + 1)
                'intNextRow = intNextRow - 1
                
            Case Else 'No delimiters left
                If intNestCount = 0 Then intNestCount = 1
                .Cells(intNextRow, intNestCount) = Chr(32) & strInput
                strInput = ""
            End Select
            intNextRow = intNextRow + 1
        Loop
        
        Range("A3").Select
        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        Selection.Columns.AutoFit
        
        Rows("2:2").Select
        ActiveWindow.FreezePanes = True
        Range("A3").Select
        
    End With

End Sub


Function NextDelimiter(strInput As String)
    'Look for  (40(  )41) ,44,  :58:   ]93]   [91[   }125}  {123{
    'in string and return which one is next
    
    Dim aryDelimiters
    Dim aryLocation
    Dim intPosition As Integer
    Dim intNext As Integer
    Dim intX As Integer
    '                      40   41   44   123  125  91   93
    aryDelimiters = Array("(", ")", ",", "{", "}", "[", "]")
    aryLocation = Array(InStr(strInput, "("), _
        InStr(strInput, ")"), _
        InStr(strInput, ","), _
        InStr(strInput, "{"), _
        InStr(strInput, "}"), _
        InStr(strInput, "["), _
        InStr(strInput, "]"))
    
    intPosition = 32000
    For intX = LBound(aryDelimiters) To UBound(aryDelimiters)
        If aryLocation(intX) > 0 And aryLocation(intX) < intPosition Then
            intNext = intX
            intPosition = aryLocation(intX)
        End If
    Next
    If intPosition = 32000 Then
        NextDelimiter = 0
    Else
        NextDelimiter = Asc(aryDelimiters(intNext))
    End If
End Function





Hello everyone,

Right now I'm trying to get a list of all the possible combos of days off during a week. Currently I'm using a series of 1's and 0's to show what days a schedule has off.

Ex: 1011101 that series means Monday/Friday off.

So basically I'm trying to find a way to show all the possible combos of 1's and 0's in a series of 7. Both with two 0's and 3 0's, corresponding to two days off and 3 days off in a week.

I found this bit of code that sounded like it would do what I needed, however trying to execute it produces an overflow error and I'm not sure how to go about fixing that. Any help would be appreciated.

Thanks

Code:

Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
'
' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc

Sub ListPermutationsOrCombinations()
Dim Rng As Range
Dim PopSize As Integer
Dim SetSize As Integer
Dim Which As String
Dim n As Double
Const BufferSize As Long = 4096

Worksheets("Sheet1").Range("A1").Select
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then
Set Rng = Range(Rng, Rng.End(xlDown))
End If

PopSize = Rng.Cells.Count - 2
If PopSize < 2 Then GoTo DataError

SetSize = Rng.Cells(2).Value
If SetSize > PopSize Then GoTo DataError

Which = UCase$(Rng.Cells(1).Value)
Select Case Which
Case "C"
n = Application.WorksheetFunction.Combin(PopSize, SetSize)
Case "P"
n = Application.WorksheetFunction.Permut(PopSize, SetSize)
Case Else
GoTo DataError
End Select
If n > Cells.Count Then GoTo DataError

Application.ScreenUpdating = False

Set Results = Worksheets.Add

vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
ReDim Buffer(1 To BufferSize) As String
BufferPtr = 0

If Which = "C" Then
AddCombination PopSize, SetSize
Else
AddPermutation PopSize, SetSize
End If
vAllItems = 0

Application.ScreenUpdating = True
Exit Sub

DataError:
If n = 0 Then
Which = "Enter your data in a vertical range of at least 4 cells." _
& String$(2, 10) _
& "Top cell must contain the letter C or P, 2nd cell is the Number" _
& "of items in a subset, the cells below are the values from Which" _
& "the subset is to be chosen."

Else
Which = "This requires " & Format$(n, "#,##0") & _
" cells, more than are available on the worksheet!"
End If
MsgBox Which, vbOKOnly, "DATA ERROR"
Exit Sub
End Sub

Private Sub AddPermutation(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0)

Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Static Used() As Integer
Dim i As Integer

If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
ReDim Used(1 To iPopSize) As Integer
NextMember = 1
End If

For i = 1 To iPopSize
If Used(i) = 0 Then
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
Used(i) = True
AddPermutation , , NextMember + 1
Used(i) = False
Else
SavePermutation SetMembers()
End If
End If
Next i

If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
Erase Used
End If

End Sub 'AddPermutation

Private Sub AddCombination(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0, _
Optional NextItem As Integer = 0)

Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Dim i As Integer

If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
NextMember = 1
NextItem = 1
End If

For i = NextItem To iPopSize
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
AddCombination , , NextMember + 1, i + 1
Else
SavePermutation SetMembers()
End If
Next i

If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
End If

End Sub 'AddCombination

Private Sub SavePermutation(ItemsChosen() As Integer, _
Optional FlushBuffer As Boolean = False)

Dim i As Integer, sValue As String
Static RowNum As Long, ColNum As Long

If RowNum = 0 Then RowNum = 1
If ColNum = 0 Then ColNum = 1

If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
If BufferPtr > 0 Then
If (RowNum + BufferPtr - 1) > Rows.Count Then
RowNum = 1
ColNum = ColNum + 1
If ColNum > 256 Then Exit Sub
End If

Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
= Application.WorksheetFunction.Transpose(Buffer())
RowNum = RowNum + BufferPtr
End If

BufferPtr = 0
If FlushBuffer = True Then
Erase Buffer
RowNum = 0
ColNum = 0
Exit Sub
Else
ReDim Buffer(1 To UBound(Buffer))
End If

End If

'construct the next set
For i = 1 To UBound(ItemsChosen)
sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
Next i

'and save it in the buffer
BufferPtr = BufferPtr + 1
Buffer(BufferPtr) = Mid$(sValue, 3)
End Sub 'SavePermutation





I have a huge list of car models inventory. About 15,000+ entries in an Excel spreadsheet. I am trying to find out the first letter of the name of the car.

I have the following four formats:
Mercedes CLS 500 (i.e., Name begins with a letter)
2000 Chevrolet Corvette (i.e., 4 numbers + space then the letter)
4x4 Jeep (i.e., number + x + number + space then the letter)
8-Wheel Tipper Truck (i.e., number plus a dash then the letter

It is very easy if the first character is a letter. I used the "Left(a1,1)" command to find the first letter. However, I am not sure how to find the first letter if the first character is a number.

Is there any easier way of find this without going through VBA?

Any help is greatly appreciated.


I've used the following code in Excel XP with no problems.
Now that I have Excel 2007, I keep getting an "Overflow" error when trying to run the code. Sometimes it will say "Runtime error '6':, Overflow"

When I step through the code (F8) the line that brings up the error is:

If N > Cells.Count Then GoTo DataError

To give an example of what values I'm entering use the following:

Cell A1 = c
Cell A2 = 5
Cells A3 - A17 = A-O (one letter per cell)

Code:

Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
'
'  Posted by Myrna Larson
'  July 25, 2000
'  Microsoft.Public.Excel.Misc
'  Subject:  Combin
'
'
'Since you asked, here it is. It is generic, i.e. it isn't written specifically
'for a given population and set size, as yours it. It will do permutations or
'combinations. It uses a recursive routine to generate the subsets, one routine
'for combinations, a different one for permutations.
'To use it, you put the letter C or P (for combinations or permutations) in a
'cell. The cell below that contains the number of items in a subset. The Cells
'below are a list of the items that make up the population. They could be
'numbers, letters and symbols, or words, etc.
'You select the top cell, or the entire range and run the sub. The subsets are
'written to a new sheet in the workbook.
'
'
Sub ListPermutations()
  Dim Rng As Range
  Dim PopSize As Integer
  Dim SetSize As Integer
  Dim Which As String
  Dim N As Double
  Const BufferSize As Long = 4096
  Set Rng = Selection.Columns(1).Cells
  If Rng.Cells.Count = 1 Then
    Set Rng = Range(Rng, Rng.End(xlDown))
  End If
  PopSize = Rng.Cells.Count - 2
  If PopSize < 2 Then GoTo DataError
  SetSize = Rng.Cells(2).Value
  If SetSize > PopSize Then GoTo DataError
  Which = UCase$(Rng.Cells(1).Value)
  Select Case Which
  Case "C"
    N = Application.WorksheetFunction.Combin(PopSize, SetSize)
  Case "P"
    N = Application.WorksheetFunction.Permut(PopSize, SetSize)
  Case Else
    GoTo DataError
  End Select
  If N > Cells.Count Then GoTo DataError
  Application.ScreenUpdating = False
  Set Results = Worksheets.Add
  vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
  ReDim Buffer(1 To BufferSize) As String
  BufferPtr = 0
  If Which = "C" Then
    AddCombination PopSize, SetSize
  Else
    AddPermutation PopSize, SetSize
  End If
  vAllItems = 0
  Application.ScreenUpdating = True
  Exit Sub
DataError:
  If N = 0 Then
    Which = "Enter your data in a vertical range of at least 4 cells. " _
      & String$(2, 10) _
      & "Top cell must contain the letter C or P, 2nd cell is the number " _
      & "of items in a subset, the cells below are the values from which " _
      & "the subset is to be chosen."
  Else
    Which = "This requires " & Format$(N, "#,##0") & _
      " cells, more than are available on the worksheet!"
  End If
  MsgBox Which, vbOKOnly, "DATA ERROR"
  Exit Sub
End Sub
Private Sub AddPermutation(Optional PopSize As Integer = 0, _
  Optional SetSize As Integer = 0, _
  Optional NextMember As Integer = 0)
  Static iPopSize As Integer
  Static iSetSize As Integer
  Static SetMembers() As Integer
  Static Used() As Integer
  Dim i As Integer
  If PopSize  0 Then
    iPopSize = PopSize
    iSetSize = SetSize
    ReDim SetMembers(1 To iSetSize) As Integer
    ReDim Used(1 To iPopSize) As Integer
    NextMember = 1
  End If
  For i = 1 To iPopSize
    If Used(i) = 0 Then
      SetMembers(NextMember) = i
      If NextMember  iSetSize Then
        Used(i) = True
        AddPermutation , , NextMember + 1
        Used(i) = False
      Else
        SavePermutation SetMembers()
      End If
    End If
  Next i
  If NextMember = 1 Then
    SavePermutation SetMembers(), True
    Erase SetMembers
    Erase Used
  End If
End Sub  'AddPermutation
Private Sub AddCombination(Optional PopSize As Integer = 0, _
  Optional SetSize As Integer = 0, _
  Optional NextMember As Integer = 0, _
  Optional NextItem As Integer = 0)
  Static iPopSize As Integer
  Static iSetSize As Integer
  Static SetMembers() As Integer
  Dim i As Integer
  If PopSize  0 Then
    iPopSize = PopSize
    iSetSize = SetSize
    ReDim SetMembers(1 To iSetSize) As Integer
    NextMember = 1
    NextItem = 1
  End If
  For i = NextItem To iPopSize
    SetMembers(NextMember) = i
    If NextMember  iSetSize Then
      AddCombination , , NextMember + 1, i + 1
    Else
      SavePermutation SetMembers()
    End If
  Next i
  If NextMember = 1 Then
    SavePermutation SetMembers(), True
    Erase SetMembers
  End If
End Sub  'AddCombination
Private Sub SavePermutation(ItemsChosen() As Integer, _
  Optional FlushBuffer As Boolean = False)
  Dim i As Integer, sValue As String
  Static RowNum As Long, ColNum As Long
  If RowNum = 0 Then RowNum = 1
  If ColNum = 0 Then ColNum = 1
  If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
    If BufferPtr > 0 Then
      If (RowNum + BufferPtr - 1) > Rows.Count Then
        RowNum = 1
        ColNum = ColNum + 1
        If ColNum > 256 Then Exit Sub
      End If
      Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
        = Application.WorksheetFunction.Transpose(Buffer())
      RowNum = RowNum + BufferPtr
    End If
    BufferPtr = 0
    If FlushBuffer = True Then
      Erase Buffer
      RowNum = 0
      ColNum = 0
      Exit Sub
    Else
      ReDim Buffer(1 To UBound(Buffer))
    End If
  End If
  'construct the next set
  For i = 1 To UBound(ItemsChosen)
    sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
  Next i
  'and save it in the buffer
  BufferPtr = BufferPtr + 1
  Buffer(BufferPtr) = Mid$(sValue, 3)
End Sub  'SavePermutation





Here's the deal!

I'd like to count how many characters my string contains, but without the use of Len function. To be more precise, I'd like to 'walk' through my string, and increase the counter for every letter I encounter.

So basically, something like this:

Code:

For Each character in string
i = i + 1
Next


The reason why I wan't it done this way is because at a later stage, I will want to insert a letter after the 50th character (for example).

But, it's the end of the day, and my brain is dead.
Help, please.

Cheers,
Ivan.


I've used the following code in Excel XP with no problems.
Now that I have Excel 2007, I keep getting an "Overflow" error when trying to run the code. Sometimes it will say "Runtime error '6':, Overflow"

When I step through the code (F8) the line that brings up the error is:

If N > Cells.Count Then GoTo DataError

To give an example of what values I'm entering use the following:

Cell A1 = c
Cell A2 = 5
Cells A3 - A17 = A-O (one letter per cell)

Any help would be greatly appreciated.

Code:

Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
'
'  Posted by Myrna Larson
'  July 25, 2000
'  Microsoft.Public.Excel.Misc
'  Subject:  Combin
'
'
'Since you asked, here it is. It is generic, i.e. it isn't written specifically
'for a given population and set size, as yours it. It will do permutations or
'combinations. It uses a recursive routine to generate the subsets, one routine
'for combinations, a different one for permutations.
'To use it, you put the letter C or P (for combinations or permutations) in a
'cell. The cell below that contains the number of items in a subset. The Cells
'below are a list of the items that make up the population. They could be
'numbers, letters and symbols, or words, etc.
'You select the top cell, or the entire range and run the sub. The subsets are
'written to a new sheet in the workbook.
'
'
Sub ListPermutations()
  Dim Rng As Range
  Dim PopSize As Integer
  Dim SetSize As Integer
  Dim Which As String
  Dim N As Double
  Const BufferSize As Long = 4096
  Set Rng = Selection.Columns(1).Cells
  If Rng.Cells.Count = 1 Then
    Set Rng = Range(Rng, Rng.End(xlDown))
  End If
  PopSize = Rng.Cells.Count - 2
  If PopSize < 2 Then GoTo DataError
  SetSize = Rng.Cells(2).Value
  If SetSize > PopSize Then GoTo DataError
  Which = UCase$(Rng.Cells(1).Value)
  Select Case Which
  Case "C"
    N = Application.WorksheetFunction.Combin(PopSize, SetSize)
  Case "P"
    N = Application.WorksheetFunction.Permut(PopSize, SetSize)
  Case Else
    GoTo DataError
  End Select
  If N > Cells.Count Then GoTo DataError
  Application.ScreenUpdating = False
  Set Results = Worksheets.Add
  vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
  ReDim Buffer(1 To BufferSize) As String
  BufferPtr = 0
  If Which = "C" Then
    AddCombination PopSize, SetSize
  Else
    AddPermutation PopSize, SetSize
  End If
  vAllItems = 0
  Application.ScreenUpdating = True
  Exit Sub
DataError:
  If N = 0 Then
    Which = "Enter your data in a vertical range of at least 4 cells. " _
      & String$(2, 10) _
      & "Top cell must contain the letter C or P, 2nd cell is the number " _
      & "of items in a subset, the cells below are the values from which " _
      & "the subset is to be chosen."
  Else
    Which = "This requires " & Format$(N, "#,##0") & _
      " cells, more than are available on the worksheet!"
  End If
  MsgBox Which, vbOKOnly, "DATA ERROR"
  Exit Sub
End Sub
Private Sub AddPermutation(Optional PopSize As Integer = 0, _
  Optional SetSize As Integer = 0, _
  Optional NextMember As Integer = 0)
  Static iPopSize As Integer
  Static iSetSize As Integer
  Static SetMembers() As Integer
  Static Used() As Integer
  Dim i As Integer
  If PopSize <> 0 Then
    iPopSize = PopSize
    iSetSize = SetSize
    ReDim SetMembers(1 To iSetSize) As Integer
    ReDim Used(1 To iPopSize) As Integer
    NextMember = 1
  End If
  For i = 1 To iPopSize
    If Used(i) = 0 Then
      SetMembers(NextMember) = i
      If NextMember <> iSetSize Then
        Used(i) = True
        AddPermutation , , NextMember + 1
        Used(i) = False
      Else
        SavePermutation SetMembers()
      End If
    End If
  Next i
  If NextMember = 1 Then
    SavePermutation SetMembers(), True
    Erase SetMembers
    Erase Used
  End If
End Sub  'AddPermutation
Private Sub AddCombination(Optional PopSize As Integer = 0, _
  Optional SetSize As Integer = 0, _
  Optional NextMember As Integer = 0, _
  Optional NextItem As Integer = 0)
  Static iPopSize As Integer
  Static iSetSize As Integer
  Static SetMembers() As Integer
  Dim i As Integer
  If PopSize <> 0 Then
    iPopSize = PopSize
    iSetSize = SetSize
    ReDim SetMembers(1 To iSetSize) As Integer
    NextMember = 1
    NextItem = 1
  End If
  For i = NextItem To iPopSize
    SetMembers(NextMember) = i
    If NextMember <> iSetSize Then
      AddCombination , , NextMember + 1, i + 1
    Else
      SavePermutation SetMembers()
    End If
  Next i
  If NextMember = 1 Then
    SavePermutation SetMembers(), True
    Erase SetMembers
  End If
End Sub  'AddCombination
Private Sub SavePermutation(ItemsChosen() As Integer, _
  Optional FlushBuffer As Boolean = False)
  Dim i As Integer, sValue As String
  Static RowNum As Long, ColNum As Long
  If RowNum = 0 Then RowNum = 1
  If ColNum = 0 Then ColNum = 1
  If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
    If BufferPtr > 0 Then
      If (RowNum + BufferPtr - 1) > Rows.Count Then
        RowNum = 1
        ColNum = ColNum + 1
        If ColNum > 256 Then Exit Sub
      End If
      Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
        = Application.WorksheetFunction.Transpose(Buffer())
      RowNum = RowNum + BufferPtr
    End If
    BufferPtr = 0
    If FlushBuffer = True Then
      Erase Buffer
      RowNum = 0
      ColNum = 0
      Exit Sub
    Else
      ReDim Buffer(1 To UBound(Buffer))
    End If
  End If
  'construct the next set
  For i = 1 To UBound(ItemsChosen)
    sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
  Next i
  'and save it in the buffer
  BufferPtr = BufferPtr + 1
  Buffer(BufferPtr) = Mid$(sValue, 3)
End Sub  'SavePermutation





Hi I have this code for a wildcard search,
Code:

Sub wildcardsearch()

 Dim Found As Boolean
 Dim FoundCell As Range
 Dim FirstAddx As String
 Dim num As String
 Dim SearchCount As Integer
 Dim wks As Worksheet
 Dim search As String
 search = Replace(TextBox1.Text, "*", "")
 
    For Each wks In Worksheets
        Select Case wks.Name
            Case "Cross-ref"  'change/add as desired"
                Set FoundCell = wks.Cells.Find(what:=Me.TextBox1.Value, LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)
                If Not FoundCell Is Nothing Then
                   Found = True
                   FirstAddx = FoundCell.Address
                   
                   Do
                     ' wks.Activate
                     'FoundCell.Select
                
                     
                     
                     
                     With Wildcard.Results_wc
                       .AddItem (FoundCell)
                    
                     End With
                     Set FoundCell = wks.Cells.FindNext(After:=FoundCell)
                     If FoundCell Is Nothing Then Exit Do
                     If FoundCell.Address = FirstAddx Then Exit Do
                     Wildcard.Show
                     
                    
                     
                     
                     
                    Loop
                End If
        End Select
    Next wks
    
    If Not Found Then
  MsgBox ("Value Not Found")
    End If
  
End Sub


But It seems not to work, any suggestions?
Also a * Must be entered to run this sub that's why it has
Code:

search = Replace(TextBox1.Text, "*", "")





In VBA, I need to check if the first letter of a character string in capitalized.
(I do NOT want to change its case, though)

e.g.,
var1 = "task"
Is the t capitalized?

I found the string function "exact()" and the information on it indicated that the string funciton is case-sensitive, so it can be used to test if the ltter cases are identical to the proper-case version of the string. Their example was checking cell A1.
=EXACT(A1,Proper(A1))

I tried:
If exact(var1,PROPER(var1)) ' this did not work

tried:
dim checkfirstchar as string
Checkfirstchar = exact(A1,Proper(A1)) " (function not defined)

Tried
dim checkfirstchar as string
If Checkfirstchar(exact(A1,Proper(A1))) then " (function not defined)
msgbox "if true, then capitalized)
end if

Your help would be so appreciated. I need this info urgently.


Hi Highly Esteemed,

I have an Excel workbook with two Columns A and B. I also have another column H which I want to populate depending on which keywords were found in A or B.

A - contains the subject of a message.
B - contains the message body itself (mean 1000 - 1200 characters).

What I want to do is of this natu

Do Until end of used range
Activate the Cell I want to populate
Use instr() function to search cell A2 (increases with loop)

If keyword found (eg. downloading) in A2 then H2 = internet

If not found
Make the search string column B (for the same record)
Repeat the search for this column (same record)

If keyword found, then populate H2
else put "undefined" in H2
.
end if
end if
loop

Now my VBA implementation works but is not very accurate - also the presence of too many if then...if then.... makes it inaccurate - I was wondering if anyone could help me code select case statements using instr() or any other suggestions.

Here is a section of my code:

Private Sub cmdReqClass_Click()
'RequestClass
'Sub RequestClass()
Dim SearchString, SearchChar, MyPos
Sheets("DataRecord").Select
Range("H2").Select

'character strings containing root words to be searched.

Searchinternet = "INTERN"
Searchpassword = "PURC"
SearchCharPrint = "PRINT"

'There are about 25 search strings in total
Do Until Selection.Offset(0, -7).Value = ""
SearchString = (UCase(Selection.Offset(0, -7).Value))

' String to search in.
' A textual comparison starting at position 1



If (InStr(1, SearchString, Searchinternet, 1) > 0) Then
ActiveCell.Value = "Internet Related"

ElseIf ((InStr(1, SearchString, SearchCharPrint , 1) > 0) ActiveCell.Value = "Printing"

Else
ActiveCell.Value = "Undefined"
HERE IS MY PROBLEM - I DONT KNOW HOW TO WRITE THE CODE TO SEARCH B2 FOR THE SAME RECORD NEATLY - I DONT KNOW HOW TO USE SELECT CASE IN THIS SITUATION AND IF IT IS APPROPRIATE!
'SearchString = (UCase(Selection.Offset(0, -13).Value)))
Select Case InStr(1, UCase(Selection.Offset(0, -6).Value), SEARCHINTERNET, 1)

Case Is > 0
ActiveCell.Value = "Internet Related"

Case Is < 0
InStr(1, UCase(Selection.Offset(0, -6).Value), SearchPass, 1)

Case Else
ActiveCell.Value = "Undefined"
End Select

End If


Selection.Offset(1, 0).Select
Loop
End Sub


OK, second string question this evening.

This procedure looks at the strings in column A (which have a series of dots
in them) and "should" add a space for every dot found to the front of the
string in the respective row in column B.

The problem is that I'm getting a blank value ("") for variable convStr even
though there is a string in the right place in column B.

Any clues?

Thanks again

John




Sub IndentListWithSpaces()

'Run down list and indent cell values to right, dependent on number of dots
in string
Dim rgListItem As Range
Dim convStr As String
Dim nDots As Integer
Dim r As Integer
Dim c As Integer
Dim totalStr As String

'Check user selects cell at top of list
Answer = MsgBox(Prompt:="Is cell at top of list selected?", Buttons:=vbYesNo
+ vbQuestion)
If Answer = vbNo Then Exit Sub

r = ActiveCell.Row
c = ActiveCell.Column

Do
Set rgListItem = Cells(r, c)
If IsEmpty(Cells(r, c)) Then Exit Do
totalStr = rgListItem.Value
nDots = 0
For x = 1 To Len(totalStr)
If Mid(totalStr, x, 1) = "." Then
nDots = nDots + 1
End If
Next x

For y = 1 To nDots
convStr = rgListItem.Offset(r, (c + 1)).Value
rgListItem.Offset(r, (c + 1)).Value = " " & convStr
Next y

r = r + 1

Loop

Cells(r, c).Select

MsgBox "Finished"

End Sub





Hello

I have a text file (in gsi format) that I need to import into excel. As I wish to later link some other functionality to the import process I need to use VBA.

The problem I have is that the data is delimited by a space and +.

I can very easily get using either the space or the + but not both.

I am pretty confident the problem is with one line ( ImportTextFile FName:=CStr(FileName), Sep:=" ","+" ) but can't nut it out.

Any help will be greatly appreciated.


Code:

Sub DoTheImport()
    Dim FileName As Variant
    Dim Sep As String
    FileName = Application.GetOpenFilename(FileFilter:="GSI File (*.GSI),*.GSI")
    If FileName = False Then
        ''''''''''''''''''''''''''
        ' user cancelled, get out
        ''''''''''''''''''''''''''
        Exit Sub
    End If
    'Sep = Application.InputBox("Enter a separator character.", Type:=2)
    'If Sep = vbNullString Then
        ''''''''''''''''''''''''''
        ' user cancelled, get out
        ''''''''''''''''''''''''''
        'Exit Sub
    'End If
    Debug.Print "FileName: " & FileName, '"Separator: " & Sep
    ImportTextFile FName:=CStr(FileName), Sep:=" ","+"
End Sub

Public Sub ImportTextFile(FName As String, Sep As String)

Dim RowNdx As Long
Dim ColNdx As Integer
Dim TempVal As Variant
Dim WholeLine As String
Dim Pos As Integer
Dim NextPos As Integer
Dim SaveColNdx As Integer

Application.ScreenUpdating = False
'On Error GoTo EndMacro:

SaveColNdx = ActiveCell.Column
RowNdx = ActiveCell.Row

Open FName For Input Access Read As #1

While Not EOF(1)
    Line Input #1, WholeLine
    If Right(WholeLine, 1) <> Sep Then
        WholeLine = WholeLine & Sep
    End If
    ColNdx = SaveColNdx
    Pos = 1
    NextPos = InStr(Pos, WholeLine, Sep)
    While NextPos >= 1
        TempVal = Mid(WholeLine, Pos, NextPos - Pos)
        Cells(RowNdx, ColNdx).Value = TempVal
        Pos = NextPos + 1
        ColNdx = ColNdx + 1
        NextPos = InStr(Pos, WholeLine, Sep)
    Wend
    RowNdx = RowNdx + 1
Wend

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' END ImportTextFile
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub





Hi could someone please help me with this? I have a VB code that pulls up my Email client and emails out the workbook as an attachment. I would like to change the code so that it just emails out the worksheet i am currently on and not the whole workbook. Can this be done? I have added the code.


Code:

Option Explicit
Private Declare Function TOISendMail Lib "TWIAPI5.DLL" (ByVal sSubject As String, ByVal sAttachedFiles As String, ByVal lpszRecipient As String, ByVal bMsgOnClipboard As Integer) As Integer
Private Declare Function TOIShowMessage Lib "TWIAPI5.DLL" (ByVal nMsgID As Integer, ByVal nType As Integer, ByVal sDetail As String) As Integer
Sub TWSendMail()
Dim sSubject As String, sFileName As String
If TWcheckSaved() = False Then Exit Sub

sFileName = ActiveWorkbook.FullName
sSubject = TWgetSubject()

Call TOISendMail(sSubject, sFileName, "", 0)
End Sub
Function TWcheckSaved() As Boolean
Dim rc As Integer

' application is running as OLE server.
If (Application.UserControl = False) Then
Call TOIShowMessage(124, 1, "")
TWcheckSaved = False
Exit Function
End If

If (ActiveWorkbook.Path = "") Then
If (Application.Dialogs(xlDialogSaveAs).Show = False) Then
TWcheckSaved = False
Exit Function
End If
End If

If (ActiveWorkbook.Saved = False) Then
rc = TOIShowMessage(130, 4, ActiveWorkbook.Name)
If (rc > 0) Then
TWcheckSaved = False
Exit Function
End If
ActiveWorkbook.Save
End If

TWcheckSaved = True
End Function
Function TWgetSubject() As String
Dim sSubject As String

sSubject = ActiveWorkbook.Title
If (sSubject = "") Then
sSubject = ActiveWorkbook.Subject
End If
If (sSubject = "") Then
sSubject = ActiveWorkbook.Name
End If
TWgetSubject = sSubject
End Function





Hi,

I am trying to compare the text content of two cells.
Basically, there is a review of the text in 100+ cells in column M, which is introduced in column O.
I would like the macro to highlight the differences for cells in those two columns (i.e. M1 to O1, M2 to O2, etc).

I would like to highlight the differences in red and bold, without changing the case or any other properties.

i.e.

M1 = Text in column M.
O1 = Reviewed text in Column O

"Reviewed" should be highlighted, as well as "M", "O" and "."

It should be case sensitive as well.

My knowledge is very limited when it comes to VBA.

I have been doing some research around and I found the code below, which partially works, but not completely.

Code:

Sub Compare()

If StringCompareHighlight(Range("m1"), Range("o1")) Then
      Range("q1").Value = "Match"
Else
      Range("q1").Value = "Not Match"
End If


If StringCompareHighlight(Range("m2"), Range("o2")) Then
      Range("q2").Value = "Match"
Else
      Range("q2").Value = "Not Match"
End If


If StringCompareHighlight(Range("m3"), Range("o3")) Then
      Range("q3").Value = "Match"
Else
      Range("q3").Value = "Not Match"
End If

End Sub

Function StringCompareHighlight(r1 As Range, r2 As Range) As Boolean
''this function compare the words from 2 strings
''each word is separated by "," and the order of these words does not matter
''return true if matches, False if not match
''changes the format of a word in one string that does not exist in the other string
Dim oMatches As Object, oMatch As Object
Dim r(1 To 2) As Range
Dim i As Integer, bDiff As Boolean, iStart As Integer
 
Set r(1) = r1
Set r(2) = r2
With CreateObject("vbscript.regexp")
    .Pattern = " *(\w+) *(?= .*\|)(?!.*\|.* *\1 *)"
    .Global = True
    .IgnoreCase = True
 
    For i = 1 To 2
        Set oMatches = .Execute(" " & r(i).Text & ",|," & r(3 - i).Text & " ")
        For Each oMatch In oMatches
            iStart = InStr(oMatch.FirstIndex + 1, r(i).Text, oMatch.submatches(0), vbTextCompare)
            With r(i).Characters(Start:=iStart, Length:=Len(oMatch.submatches(0))).Font
                .Bold = True
                .Size = 14
            End With
        Next oMatch
        If oMatches.Count > 0 Then bDiff = True
    Next i
End With
StringCompareHighlight = Not bDiff
End Function


Can someone help me with this?

Many thanks,

Luis


Hi I'm trying to write a macro that will get me the letter of the last non blank column. If there is a way to get the letter value for the next blank column that would be best. The end goal will be a macro that will add columns to a spreadsheet using an input box with formula added to certain rows. The below code gives an error message



Code:

 Sub Convert_Column()
       Dim MyColumn As String, Here As String

       ' Get the address of the active cell in the current selection
       LastCol = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
       Here = ActiveCell.Address

       ' Because .Address is $$, drop the first
       ' character and the characters after the column letter(s).
       MyColumn = Mid(LastCol, InStr(LastCol, "$") + 1, InStr(2, LastCol, "$") - 2)

       ' Show the answer.
       MsgBox MyColumn

   End Sub





Hi there,

I am currently running a code which automatically updates 30 or sharts at once by adding 1 column to the beginning and end of the series. For example Chart 1 refers to columns A to E, after running the macro the Range will change to B to F.
Currently, all the charts have 3 series, if i try to add a 4th series to the chart and macro it does not work.

How can I amend the code so that it updates all 4 series in all of the charts instead of updating just three series for all charts?

I have added the 4th series to each of the chart, that I would like to be updated along with the 3 other series that are being update everytime i run the macro.



I have copied the existing code below. Currently, when i try to run it i get the error on the line:OrigCNo = Mid(R1C1In, InStr(1, R1C1In, "C") + 1).

I am only a beginner at Excel VBA so your help would be kindly appreciated.

Kind regards,

Bob

Option Explicit

Sub WeeklyChartUpdate()
Call UpdateChartFormula
Call SetPrintArea
MsgBox "Chart areas updated", vbOKOnly
End Sub


Sub UpdateChartFormula()
Dim chrt As Object
Dim i As Integer, k As Integer
Dim SeriesFormula() As String, ReturnFormula As String, R1C1Part As String
Const CurrentYear As String = "2008"

For Each chrt In ActiveSheet.ChartObjects
Select Case True
'checks chart names that have been defined using one off sub NameCharts()
'will categorise charts as either "rolling" type or "yearly" type - they need
'to be treated differently
Case chrt.Name Like "*Rolling*"
'change start and end points of all series
For i = 1 To chrt.Chart.SeriesCollection.Count
SeriesFormula = Split(chrt.Chart.SeriesCollection(i).FormulaR1C1, ",")
For k = 0 To UBound(SeriesFormula)
Debug.Print SeriesFormula(k)
If k = 1 Or k = 2 Then
'AXIS or VALUE part of formula (these are fixed positions 1 & 2)
'we want to change both parts of the formula - the start and the end point
'the "rolling" charts are a 12 week rolling total summary so both points move
'find the first RC part of the formula (from the ! to the : part)
'add 1 to the C
R1C1Part = Mid(SeriesFormula(k), InStr(1, SeriesFormula(k), "!") + 1, (Len(SeriesFormula(k)) - InStr(1, SeriesFormula(k), ":")) - 1)
SeriesFormula(k) = Replace(SeriesFormula(k), R1C1Part, OffsetC1(R1C1Part))
'find the second RC part of the formula (from the : to the end)
'add 1 to the C
R1C1Part = Mid(SeriesFormula(k), InStr(1, SeriesFormula(k), ":") + 1)
SeriesFormula(k) = Replace(SeriesFormula(k), R1C1Part, OffsetC1(R1C1Part))
End If
Next k
'rebuild formula
ReturnFormula = Join(SeriesFormula(), ",")
chrt.Chart.SeriesCollection(i).FormulaR1C1 = ReturnFormula
Next i
Case chrt.Name Like "*Yearly*"
'change current year series only - this will need to be changed on a yearly basis!!!
For i = 1 To chrt.Chart.SeriesCollection.Count
If chrt.Chart.SeriesCollection(i).Name Like "*" & CurrentYear & "*" Then
SeriesFormula = Split(chrt.Chart.SeriesCollection(i).FormulaR1C1, ",")
For k = 0 To UBound(SeriesFormula)
Debug.Print SeriesFormula(k)
If k = 2 Then
'VALUE part of formula only
'find ONLY the second RC part of the formula (from the : to the end)
'we don't want to change the starting point for the current year series, or the AXIS values-
'always want to see the year to date totals
R1C1Part = Mid(SeriesFormula(k), InStr(1, SeriesFormula(k), ":") + 1)
SeriesFormula(k) = Replace(SeriesFormula(k), R1C1Part, OffsetC1(R1C1Part))
End If
Next k
'rebuild formula
ReturnFormula = Join(SeriesFormula(), ",")
chrt.Chart.SeriesCollection(i).FormulaR1C1 = ReturnFormula

End If
Next i
Case Else
MsgBox "Unrecognised Chart name - if you have inserted a new chart you will need to rename it. Please contact IT (hs)", vbCritical, "SOME CHARTS WILL NOT UPDATE PROPERLY"
End Select

Next chrt
End Sub

Sub SetPrintArea()
Dim PA1 As String, PA2 As String, PA As String
'Print areas
Dim D1Pos As Integer, D2Pos As Integer, D3Pos As Integer, D4Pos As Integer
'Position of $ in string - to calculate where the column headers are
'takes current print area and moves it along 1
D1Pos = InStr(1, ActiveSheet.PageSetup.PrintArea, "$")
D2Pos = InStr(D1Pos + 1, ActiveSheet.PageSetup.PrintArea, "$")
D3Pos = InStr(D2Pos + 1, ActiveSheet.PageSetup.PrintArea, "$")
D4Pos = InStr(D3Pos + 1, ActiveSheet.PageSetup.PrintArea, "$")

PA = ActiveSheet.PageSetup.PrintArea

PA1 = Mid(ActiveSheet.PageSetup.PrintArea, D1Pos + 1, D2Pos - D1Pos - 1)
PA2 = Mid(ActiveSheet.PageSetup.PrintArea, D3Pos + 1, D4Pos - D3Pos - 1)
PA = Replace(PA, PA1, GetNextColumn(PA1))
PA = Replace(PA, PA2, GetNextColumn(PA2))

ActiveSheet.PageSetup.PrintArea = PA
End Sub

Function OffsetC1(ByVal R1C1In As String)
Dim OrigCNo As Integer, R1C1Out As String

OrigCNo = Mid(R1C1In, InStr(1, R1C1In, "C") + 1)
OffsetC1 = Replace(R1C1In, "C" & OrigCNo, "C" & OrigCNo + 1)

End Function
Function GetNextColumn(ByVal InChar As String) As String

Dim ExcelColumns As Variant
Dim i As Integer
Dim GotChar As Boolean
On Error GoTo GetNextColumn_Err

GotChar = False

InChar = UCase(InChar)
ExcelColumns = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
"AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", _
"BA", "BB", "BC", "BD", "BE", "BF", "BG", "BH", "BI", "BJ", "BK", "BL", "BM", "BN", "BO", "BP", "BQ", "BR", "BS", "BT", "BU", "BV", "BW", "BX", "BY", "BZ", _
"CA", "CB", "CC", "CD", "CE", "CF", "CG", "CH", "CI", "CJ", "CK", "CL", "CM", "CN", "CO", "CP", "CQ", "CR", "CS", "CT", "CU", "CV", "CW", "CX", "CY", "CZ", _
"DA", "DB", "DC", "DD", "DE", "DF", "DG", "DH", "DI", "DJ", "DK", "DL", "DM", "DN", "DO", "DP", "DQ", "DR", "DS", "DT", "DU", "DV", "DW", "DX", "DY", "DZ", _
"EA", "EB", "EC", "ED", "EE", "EF", "EG", "EH", "EI", "EJ", "EK", "EL", "EM", "EN", "EO", "EP", "EQ", "ER", "ES", "ET", "EU", "EV", "EW", "EX", "EY", "EZ", _
"FA", "FB", "FC", "FD", "FE", "FF", "FG", "FH", "FI", "FJ", "FK", "FL", "FM", "FN", "FO", "FP", "FQ", "FR", "FS", "FT", "FU", "FV", "FW", "FX", "FY", "FZ", _
"GA", "GB", "GC", "GD", "GE", "GF", "GG", "GH", "GI", "GJ", "GK", "GL", "GM", "GN", "GO", "GP", "GQ", "GR", "GS", "GT", "GU", "GV", "GW", "GX", "GY", "GZ", _
"HA", "HB", "HC", "HD", "HE", "HF", "HG", "HH", "HI", "HJ", "HK", "HL", "HM", "HN", "HO", "HP", "HQ", "HR", "HS", "HT", "HU", "HV", "HW", "HX", "HY", "HZ", _
"IA", "IB", "IC", "ID", "IE", "IF", "IG", "IH", "II", "IJ", "IK", "IL", "IM", "IN", "IO", "IP", "IQ", "IR", "IS", "IT", "IU", "IV")

i = 0
Do While GotChar = False
If ExcelColumns(i) = InChar Then
GotChar = True
Else
i = i + 1
End If
Loop
GetNextColumn = ExcelColumns(i + 1)
'End If

GetNextColumn_Exit:
Exit Function

GetNextColumn_Err:

If Err.Number = 9 Then
Select Case InChar
Case Is = ""
MsgBox "Valid character required"
GetNextColumn = ""
Case Is = "IV"
MsgBox "This is the last available column header (IV)"
GetNextColumn = "IV"
Case Else
MsgBox "Invalid Excel column header " & InChar
GetNextColumn = ""
End Select
Resume GetNextColumn_Exit
Else
MsgBox Err.Description
Resume GetNextColumn_Exit
End If
End Function