Find First Lower Case Letter In String - Vba Conumdrum!

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

 Option Explicit
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
 
  StrLen = Len(Selection)  
  str = Selection.Value  
  For i = 1 To StrLen  
  Exitfor = False  
  For j = 97 To 122  
  If InStr(i, str, Chr(j), vbBinaryCompare) = 1 Then  
  Exitfor = True  
  Exit For  
  Else  
  MsgBox Chr(j)  
  End If  
  Next j  
  If Exitfor = True Then Exit For  
  Next i  
  MsgBox i  
  End Sub  
 

Private Function IsRoman(chk As String) As Boolean
Dim rmn As String, z As Integer, sv As Integer
If chk = "" Then Exit Function
rmn = "MCLXDIV"
IsRoman = True
For z = 1 To Len(chk)
     If InStr(1, rmn, Mid(chk, z, 1)) = 0 Then
        IsRoman = False
        Exit For
    End If
Next
End Function

Public Function IsRoman(chk As String) As Boolean
Dim rmn As String
rmn = "(M|C|L|X|D|I|V)"
With CreateObject("vbscript.regexp")
    .Pattern = rmn
    .Global = True
    IsRoman = .test(chk)
End With
End Function

Public Function IsRoman(chk As String) As Boolean
Dim rmn As String
rmn = "(M|C|L|X|D|I|V)"
With CreateObject("vbscript.regexp")
    .Pattern = rmn
    .Global = True
    IsRoman = Len(.Replace(chk, "")) = 0
End With
End Function

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

Hi there,

I've put together a procedure that deletes the first letter in each string
in a column of data. It works, but I can't help feel there's a more
efficient way of doing this. For example, is there a way of just editing
the string itself rather than taking a virtual copy and then replacing the
original as I've done here?

All comments most welcome.

Thanks

John


Sub RemoveFirstLetterInList()
'Deletes first letter in string per cell in list
Dim rgListItem As Range
Dim newStr As String
Dim ll 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
ll = Len(totalStr) - 1
newStr = Right(totalStr, ll)
rgListItem.Value = newStr

r = r + 1
Loop

Cells(r, c).Select

MsgBox "Finished"

End Sub

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?

Is there a way to loop though a string and pull out each letter and assign it to its own variable that can be recaled using Letter1 letter2 ect?

Code:

Sub IndivLetter()

Dim num As Integer
Dim strArray() As String
Dim strText As String
Dim lLoop As Long, lCount As Long
Dim Letter(1 To 20)  As Variant



'pull out each letter and assign numeric value
strText = "Thisisareallylongstringtestwithnospaces"
    lCount = Len(strText)
    ReDim strArray(lCount - 1)

        For lLoop = 0 To lCount - 1
            y = lLoop
            strArray(lLoop) = Mid(strText, lLoop + 1, 1)
            Letter & lLoop  = strArray(lLoop)
            
        Next lLoop

     MsgBox Letter1
     MsgBox Letter4

End Sub

I have gotten this to work with a message box but I want to have each letter be assigned as it's own varible or string.
Code:

For Counter = 1 To Len(part3)

Letter & Counter = Mid(part3, Counter, 1)
    'do something to each character in string
    'here we'll msgbox each character
    MsgBox Mid(part3, Counter, 1)
Next

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!

Hi all,

My code is meant to ensure a string in a cell begins with three letters and ends with 5 numbers. It seems to work, but how can I exit the loop and go to the message box once the boolean variable is set to true? I was hoping to avoid using labels. Also, I would appreciate any suggestions in compacting the code if possible, but without using CreateObjects". Thank you


Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("h17")) Is Nothing Then Exit Sub

Dim Ls As String
Dim i As Integer, z As Integer
Dim MyString As String
Dim MyClVal As String: MyClVal = Target.Value
Dim MyBL As Boolean: MyBL = False

If Len(MyClVal)  8 Then Exit Sub

Rem FIRST THREE STRINGS ARE LETTERS
For i = 1 To 3
    MyString = Asc(Mid(UCase(Range("H17").Value), i, 1))
    If MyString < 65 Or MyString > 90 Then
    MyBL = True
    End If
Next i

Rem LAST 5 STRINGS ARE NUMBERS
MyString = ""
For z = 4 To 8
    MyString = Asc(Mid(UCase(Range("H17").Value), z, 1))
    If MyString < 48 Or MyString > 57 Then
    MyBL = True
    End If
Next z

Rem MESSAGE IF ERROR
If MyBL Then
    MsgBox "You must enter a valid number." & vbLf & vbLf & _
    "Please try again."
    Target.ClearContents: Target.Activate
    Else
    Range("h17") = StrConv(Range("h17"), vbUpperCase)
End If

End Sub

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

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.

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.

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,
I need to write a macro that will search for predefined criteria and delete it. The find results have to be whole words and can appear as the last thing in a cell, so there's not always a space preceeding/following the word.

I was able to find a macro that does exactly what I want, but it's programmed with an input box to do one at a time finds. This is highly inconvenient as I have 20+ finds to do, so I need to be able to loop through all of my finds. I tried to tweak this macro with no success.

Here's the macro that does work:



Sub OneAtATime()
Dim WorkRange As Range
Dim OldStr As Variant
Dim NewStr As Variant
Dim Match As Variant
Dim c As Range
Dim Punc As Variant
Dim x As Integer
Dim y As Integer
Dim Str As String
Dim Pos As Integer
Dim OldPos As Integer
On Error Resume Next
Set WorkRange = Selection.SpecialCells(xlCellTypeConstants, 2)
If Err 0 Then
MsgBox "No cells found"
Exit Sub
End If
On Error GoTo 0
OldStr = InputBox("Replace what", "Replace whole word")
If OldStr = "" Then Exit Sub
NewStr = InputBox("Replace with", "Replace whole word")
' Match = MsgBox("Match Case?", vbYesNo, "Replace whole word")
' If Match = vbYes Then Match = vbBinaryCompare Else Match = vbTextCompare
Punc = Array(" ", ",", ";", ":", ".")
For Each c In WorkRange
If StrComp(c.Value, OldStr, Match) = 0 Then
c.Value = NewStr
End If
If StrComp(Left(c.Value, Len(OldStr)), OldStr, Match) = 0 Then
For x = LBound(Punc) To UBound(Punc)
If StrComp(Left(c.Value, Len(OldStr) + 1), OldStr & Punc(x), Match) = 0 Then
c.Value = NewStr & Mid(c.Value, Len(OldStr) + 1, Len(c.Value) - Len(OldStr))
Exit For
End If
Next x
End If
If StrComp(Right(c.Value, Len(OldStr)), OldStr, Match) = 0 Then
For x = LBound(Punc) To UBound(Punc)
If StrComp(Right(c.Value, Len(OldStr) + 1), Punc(x) & OldStr, Match) = 0 Then
c.Value = Left(c.Value, Len(c.Value) - Len(OldStr)) & NewStr
Exit For
End If
Next x
End If
For x = LBound(Punc) To UBound(Punc)
For y = LBound(Punc) To UBound(Punc)
Str = Punc(x) & OldStr & Punc(y)
OldPos = 1
Do
Pos = InStr(OldPos, c.Value, Str, 1)
If Pos > 0 Then
If StrComp(Mid(c.Value, Pos, Len(Str)), Str, Match) = 0 Then
c.Value = WorksheetFunction.Substitute(c.Value, Mid(c.Value, Pos, Len(Str)), Punc(x) & NewStr & Punc(y), 1)
Exit For
End If
End If
OldPos = Pos + 1
Loop While Pos > 0
Next y
Next x
c.Value = WorksheetFunction.Trim(c.Value)
Next c
End Sub



I would appreciate any help to tweak this macro. I would prefer to build an array of the values to be searched for. Another option which would be okay, would be to add a worksheet and in column A, I could enter all values for searching - not sure which is easier.

Thanks,
Michelle

A few days back in helping a member of newsgroup I have to find number of occurrence of a particular sub string in a string which is entered in a cell. I tried Google search as well as Mr. excel forum search I was not able to get a satisfactory reference.
So I created a function to solve this problem. I do not know whether
1) this is sufficiently elegant and general function which my peers in the newsgroup approve
2)I hope I am not reinventing the wheel.
3) It will be a useful reference.

If the administrator thinks that this is a not worthwhile post he/she may discard this post. If he/she decides to modify he/she is at liberty to do it.

I am giving the fuction and a example of procedure for using the function.

Code:

Private Function char_nr(r As Range, y As String) As Integer
'this counts number of occasions when a sub string occurs in a string
'r is the range where the string is located
'y is the string whose repeated occurence is couned.
Dim j As Integer, m As Integer, x As String
On Error GoTo outsideloop
x = r.Value
j = 0
m = 1
Do

m = WorksheetFunction.Search(y, x, m)
j = j + 1
m = m + 1
Loop
outsideloop:
char_nr = j
End Function

Code:

Sub test()
'suppose cell A1 contains this string "MC3626, MC3631 MC3681, MC3646"
'and we want to find out how many Ms are in A1.
Dim rng As Range, z As String
Set rng = Range("a1")
z = InputBox("type character or substring to be counted, in this case M")
MsgBox char_nr(rng, z)
End Sub

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

Hi,
I need a little help here to unhide my sheets.
For now it works fine with just one critiria.

Suppose textbox1 & textbox2 meets critiria then set that row as row and then starting from col 3 do untill cell.value = ""
unhide each sheet depending on = each cell value.


Thanks for helping.
Pedie

PS: Please lemmi know if my question is not explained well enough.
Code:

 Private Sub CommandButton1_Click()
Dim name As String
Dim password As String
Dim Response As Integer
Dim i As Long
'Dim x As String
name = UserForm1.TextBox1.Value
password = UserForm1.TextBox2.Value 
          With Sheets("Home").Range("A1:A17")
          Set c = .Find(name, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                If c Is Nothing Then
                    Response = MsgBox("The name you entered was not found in the list", _
                    vbCritical + vbRetryCancel, "Name Not Found")
                        Select Case Response
                            Case vbRetry
                                TextBox1.Value = ""
                                TextBox1.SetFocus
                                Exit Sub
                            Case vbCancel
                                Unload Me
                                Exit Sub
                            End Select
                End If
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address  firstAddress
                End If
        End With
        If c.Offset(0, 1) = password Then
        x = ActiveCell.Offset(1, 0).Value
        MsgBox "Sucessful..."
        With Sheets("Home")
        x = c.Offset(0, 2).Value
        Sheets(x).Visible = xlSheetVisible
        Sheets(x).Select
        End With
        Unload Me
        Else
        Response = MsgBox("Password does not match", _
                    vbCritical + vbRetryCancel, "Password not Verified...")
                        Select Case Response
                            Case vbRetry
                                TextBox2.Value = ""
                                TextBox2.SetFocus
                                Exit Sub
                            Case vbCancel
                                Unload Me
                                Exit Sub
                            End Select
        End If
End Sub
 

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)

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