Related
Previous Record and Next Record sub routine is not working. I marked with 1 and 2. These two navigation bars (1&2) works on the what is entered on WaypointId.
Say for example, if I say waypoint id=1235, then next record should appear in a data entry form. My vba code is first search the row number of waypoint id in observation sheet and then I decrease the row number by 1 for displaying previous record and increase the row number by 1 for next record. Depends on the functionality it shows data in the Data Entry Form.
My VBA code is not working for those two things. Attach workbook with name Problem-1.xlsm See Navigation Control Module.
Sub FindRecord(WyPt)
Dim Value As String
WyPtRow = 0
ReadRow = 2
Value = Cells(ReadRow, 2)
While Value <> ""
If WyPt = Value Then
WyPtRow = ReadRow
Exit Sub
End If
ReadRow = ReadRow + 1
Value = Cells(ReadRow, 2)
Wend
End Sub
Sub ViewPreviousRecord()
Set DEFrm = Sheets("DataEntryForm")
Set ObsData = Sheets("Observations")
Dim WyPt As String
WyPt = Trim(DEFrm.Cells(6, 2))
Call FindRecord(WyPt)
LastRow = WyPtRow - 1
With DEFrm
.Cells(6, 2).Value = ObsData.Cells(LastRow, 2).Value 'WaypointID
.Cells(6, 4).Value = ObsData.Cells(LastRow, 3).Value 'ObsType
.Cells(8, 2).Value = ObsData.Cells(LastRow, 4).Value 'Date
.Cells(8, 4).Value = ObsData.Cells(LastRow, 5).Value 'LoggedBy
End With
End Sub
Sub ViewNextRecord()
Set DEFrm = Sheets("DataEntryForm")
Set ObsData = Sheets("Observations")
Dim WyPt As String
WyPt = Trim(DEFrm.Cells(6, 2))
Call FindRecord(WyPt)
LastRow = WyPtRow + 1
With DEFrm
.Cells(6, 2).Value = ObsData.Cells(LastRow, 2).Value 'WaypointID
.Cells(6, 4).Value = ObsData.Cells(LastRow, 3).Value 'ObsType
.Cells(35, 10).Value = ObsData.Cells(LastRow, 115) 'Photo4Desc
End With
End Sub
This is the most important procedure in your project.
Sub DisplayRecord(ByVal Rs As Long)
' 235
Dim Arr As Variant ' Data from row Rs in database
Dim Target() As String ' Dashboard addresses matching Arr
Dim i As Long ' loop counter: Arr(Index)
' cell addresses are aligned with column numbers in database (-2)
Arr = "B6,D6,B8,D8,G6,H6,G7,H7,G8,H8,B11,C11,D11,E11,F11,G11,H11,I11"
Arr = Arr & ",B14,C14,D14,E14,F14,G14,B17,C17,D17,E17,F17,G17"
Arr = Arr & ",I14,J14,I15,J15,I16,J16,I17,J17,B20,C20,D20,E20,F20,G20"
Arr = Arr & ",B23,C23,D23,E23,F23"
Arr = Arr & ",I20,J20,K20,I21,J21,K21,I2,J22,K22,I23,J23,K23"
Arr = Arr & ",B26,C26,D26,E26,F26,G26,H26,I26,J26,K26"
Arr = Arr & ",B27,C27,D27,E27,F27,G27,H27,I27,J27,K27"
Arr = Arr & ",B28,C28,D28,E28,F28,G28,H28,I28,J28,K28"
Arr = Arr & ",B29,C29,D29,E29,F29,G29,H29,I29,J29,K29"
Arr = Arr & ",B32,H32,I32,J32,H33,I33,J33,H34,I34,J34,H35,I35,J35"
Target = Split(Arr, ",")
With Sheets("Observations")
Arr = .Range(.Cells(Rs, 1), .Cells(Rs, 115)).Value
End With
Application.ScreenUpdating = False ' speed up execution
For i = 2 To UBound(Arr, 2) ' skip first database column
Sheets("DataEntryForm").Range(Target(i - 2)).Value = Arr(1, i)
Next i
Application.ScreenUpdating = True
End Sub
It displays the data of the row Rs given to it as an argument. You already have a function that finds the row number needed by the above procedure. Below please find an improvement.
Function RecordRow(ByVal WyPt As String) As Long
' 235
' return the row number where WyP was found or 0
Dim Fnd As Range
With Worksheets("Observations")
Set Fnd = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp))
Set Fnd = Fnd.Find(WyPt, , LookIn:=xlValues, lookat:=xlWhole)
If Not Fnd Is Nothing Then
RecordRow = Fnd.Row
End If
End With
End Function
The deal is simple: you give the Waypoint ID and receive the row number where it was found. If it isn't found the function returns 0, and that is how you avoid crashes.
With these two procedures in place you can easily call up the first and the last records.
Sub ViewFirstRecord()
' 235
DisplayRecord 2
End Sub
Sub ViewLastRecord()
' 235
With Worksheets("Observations")
DisplayRecord .Cells(.Rows.Count, "A").End(xlUp).Row
End With
End Sub
The next and previous records are just a matter of finding the row number and displaying its data.
Sub ViewNextRecord()
' 235
Dim Rs As Long ' data source row
Rs = RecordRow(Trim(Cells(6, 2).Value)) + 1
If Rs > 1 Then
With Worksheets("Observations")
If Rs <= .Cells(.Rows.Count, "A").End(xlUp).Row Then
DisplayRecord Rs
Else
MsgBox "No more records to show.", vbInformation, "Last record"
End If
End With
End If
End Sub
Sub ViewPreviousRecord()
' 235
Dim Rs As Long ' data source row
Rs = RecordRow(Trim(Cells(6, 2).Value)) - 1
If Rs > 1 Then
DisplayRecord Rs
Else
MsgBox "No more records to show.", vbInformation, "First record"
End If
End Sub
If that's the whole code, you may be finding a problem with scope. It seems ViewPreviousRecord() is not able to see WyPtRow.
You can try adding
dim WyPtRow
Before the Sub FindRecord(WyPt) definition.
Another implementation would be changing the Sub for a function, and returning the WyPtRow value.
Hopefully the title is clear. I am trying to search through multiple tables on a single sheet. The information I am looking for is the same for all of the tables, just that the corresponding column is located in different spots (e.g. in one table the column I want to search is in I, while for another table it could be in O.) which makes it a bit more challenging for me.
I want to search through each column that has the same title (Load Number) and depending on its value, copy that entire row over to a sheet that corresponds with that value.
Below is what I have so far in VBA as well as a picture to hopefully clarify my issue.
Any help/advice is appreciated!
http://imgur.com/a/e9DyH
Sub Load_Number_Finder()
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
j = 1
Set ws = Sheets.Add(After:=Sheets("Master"))
ws.Name = ("Test Load " & j)
i = 1
Sheets("Master").Select
For Each cell In Sheets("Master").Range("M:M")
If cell.Value = "1" Then
j = 1
'Set WS = Sheets.Add(After:=Sheets("Master"))
'WS.Name = ("Test Load " & j)
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Test Load " & j).Select
ActiveSheet.Rows(i).Select
ActiveSheet.Paste
Sheets("Master").Select
i = i + 1
ElseIf cell.Value = "" Then
' 2, 3, 4, 5, cases
Else
' Something needs to go here to catch when it doesnt have a load number on it yet
End If
' Err_Execute:
' MsgBox "An error occurred."
Next
End Sub
Try this function. This should work for you. Let me know what the results are with your sheet. I made a mock up sheet and tested it, it worked. I can make changes if this is not exactly what you are looking for.
Option Explicit
Sub copyPaste()
Dim rowCount, row_ix, temp, i As Integer
Dim TD_COL_IX As Integer
Dim td_value As String
Dim td_values() As String
rowCount = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
For row_ix = 1 To rowCount
temp = isNewTable(CInt(row_ix))
If temp > 0 Then
TD_COL_IX = temp
ElseIf TD_COL_IX > 0 Then
td_value = Worksheets("Master").Cells(row_ix, TD_COL_IX)
If Not td_value = "" Then
td_values = Split(td_value, " ")
For i = 0 To UBound(td_values)
If Not sheetExists("Test Load " & td_values(i)) Then
Sheets.Add.Name = "Test Load " & td_values(i)
End If
If Worksheets("Test Load " & td_values(i)).Cells(1, 1).Value = "" Then
Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), Worksheets("Master").Cells(row_ix, TD_COL_IX - 1)).Copy _
Destination:=Worksheets("Test Load " & td_values(i)).Cells(1, 1)
Else
Dim rowCount_pasteSheet As Integer
rowCount_pasteSheet = Worksheets("Test Load " & td_values(i)).Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), Worksheets("Master").Cells(row_ix, TD_COL_IX - 1)).Copy _
Destination:=Worksheets("Test Load " & td_values(i)).Cells(rowCount_pasteSheet + 1, 1)
End If
Next i
End If
End If
Next row_ix
End Sub
Function isNewTable(row_ix As Integer) As Integer
Dim colCount, col_ix As Integer
colCount = Worksheets("Master").Cells(row_ix, Columns.Count).End(xlToLeft).Column
For col_ix = 1 To colCount
If Not IsError(Worksheets("Master").Cells(row_ix, col_ix).Value) Then
If Worksheets("Master").Cells(row_ix, col_ix).Value = "LD #" Then
isNewTable = col_ix
Exit Function
End If
End If
Next col_ix
isNewTable = 0
End Function
' ####################################################
' sheetExists(sheetToFind As String) As Boolean
'
' Returns true if the sheet exists, False otherwise
' ####################################################
Public Function sheetExists(sheetToFind As String) As Boolean
Dim sheet As Worksheet
sheetExists = False
For Each sheet In Worksheets
If sheetToFind = sheet.Name Then
sheetExists = True
Exit Function
End If
Next sheet
End Function
I am trying to build a collection and take the Count of Unique Values from that Collection but am getting an error in building a Collection itself. Can anyone suggest me where I am going wrong. Kindly Share your thoughts. Please let me know how to find out the COUNT of UNIQUE VALUES as well.
Sub trial()
Dim sampleVisualBasicColl As Collection
For i = 2 To 10
Rng = Range("M" & i).value
StartsWith = Left(Rng, 3)
If StartsWith = "Joh" Then
sampleVisualBasicColl.Add Rng
Else
End If
Next
Debug.Print (sampleVisualBasicCol1)
End Sub
Using a collection you can just add Joh to the collection and then count the items:
'Using a collection
Sub Col_test()
Dim cCol As Collection
Dim i As Long
Set cCol = New Collection
On Error GoTo Err_Handler
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Left(.Cells(i, 13), 3) = "Joh" Then
cCol.Add .Cells(i, 13).Value, .Cells(i, 13).Value
End If
Next i
End With
Debug.Print cCol.Count
On Error GoTo 0
Exit Sub
Err_Handler:
Select Case Err.Number
Case 457 'This key is already associated with an element of this collection
Err.Clear
Resume Next
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure Col_test."
Err.Clear
End Select
End Sub
If you want the count of each item (Joh, Ben... whatever else you have) then use a dictionary:
'Using a dictionary.
Sub Dic_Test()
Dim dict As Object
Dim i As Long
Dim sValue As String
Dim key As Variant
Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Len(.Cells(i, 13)) >= 3 Then
sValue = Left(.Cells(i, 13), 3)
If dict.exists(sValue) Then
dict(sValue) = dict(sValue) + 1
Else
dict(sValue) = 1
End If
End If
Next i
End With
For Each key In dict.keys
Debug.Print key & " = " & dict(key)
Next key
End Sub
Note: I'm using Cells within the code rather than Range. Cells(2,13) is M2 (13th column, 2nd row).
I find this link very helpful with dictionaries: https://excelmacromastery.com/vba-dictionary/
As a further update (after answer accepted) and using the lists you gave in your question here: Excel VBA - Formula Counting Unique Value error this code with dictionaries will return Joh = 4, Ian = 3
'Using a dictionary.
Sub Dic_Test()
Dim dict As Object
Dim dictFinal As Object
Dim i As Long
Dim sValue As String
Dim key As Variant
Dim keyFinal As String
Set dict = CreateObject("Scripting.Dictionary")
Set dictFinal = CreateObject("Scripting.Dictionary")
'Get the unique values from the worksheet.
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Len(.Cells(i, 13)) >= 3 Then
sValue = .Cells(i, 13).Value
If dict.exists(sValue) Then
dict(sValue) = dict(sValue) + 1
Else
dict(sValue) = 1
End If
End If
Next i
End With
'Count the unique values in dict.
For Each key In dict.keys
keyFinal = Left(key, 3)
If dictFinal.exists(keyFinal) Then
dictFinal(keyFinal) = dictFinal(keyFinal) + 1
Else
dictFinal(keyFinal) = 1
End If
Next key
For Each key In dictFinal.keys
Debug.Print key & " = " & dictFinal(key)
Next key
End Sub
You need to create the collection as well as declaring it.
Sub trial()
Dim myCol As Collection
Set myCol= New Collection ' creates the collection
For i = 2 To 10
Rng = Range("M" & i).value
StartsWith = Left(Rng, 3)
If StartsWith = "Joh" Then
myCol.Add Rng
Else
End If
Next
For each x in myCol
Debug.Print x
Next x
End Sub
Hey this code will help u since it's collecting Unique values in Listbox,,
Private Sub UserForm_Initialize()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Set sh = ThisWorkbook.Sheets("Sheet1")
Set Rng = sh.Range("A2", sh.Range("A2").Value ="John". End(xlDown))
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
Me.ListBox1.AddItem vNum
Next vNum
End Sub
You have not declared Variable Rng & i these are the most important thing to do. Meanwhile I would like to suggest this Formula,,
=Sum(if(Frequency (if(Len(B2 :B20) >0,Match(B2 :B20, B2 :B20, 0),""),if(Len(B2 :B20) >Match(B2 :B20, B2 :B20, 0),"",))>0,1))
Its Array formula so finish with Ctrl +shift +enter.
You can use this one also,
Sub CountUnique()Dim i, count, j As Integer count = 1 For i = 1 To 470 flag = False If count
1 Then For j = 1 To count If Sheet1.Cells(i,
3).Value = Sheet1.Cells(j, 11).Value Then flag
= True End If Next j Else flag = False End If If flag = False Then Sheet1.Cells(count,
11 ).Value = Sheet1.Cells(i, 3).Value count = count + 1 End IfNext i Sheet1.Cells( 1 ,
15 ).Value = count End Sub
What I am doing is search some strings one by one in the entire range - like search for "blah1", if found then exit, else search "blah2" in the entire range in the same manner. "blah's" are searched in one column.
Right now i am just running a For loop code as shown below which so far works ok in my tests...but was wondering if MATCH, FIND or other methods may be faster...any opinion?
Sub test()
Dim LR As Long
LR = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
If Cells(1, "B") = "" Then
For i = 1 To LR
If Cells(i, "A") = "blah1" Then
Cells(1, "B") = Cells(i, "A").Row
Cells(1, "C") = Cells(i, "A")
Exit For
End If
Next i
End If
If Cells(1, "B") = "" Then
For i = 1 To LR
If Cells(i, "A") = "blah2" Then
Cells(1, "B") = Cells(i, "A").Row
Cells(1, "C") = Cells(i, "A")
Exit For
End If
Next i
End If
End Sub
Try this one. Since your code is repeated (for "blah1" and "blah2") I used additional function:
Sub test()
If Sheet1.Cells(1, "B") = "" Then
If findString("blah1") Then Exit Sub
If findString("blah2") Then Exit Sub
End If
End Sub
'Function findString returns TRUE if something found and FALSE otherwise
Function findString(searchString As String) As Boolean
Dim rng As Range, res
With Sheet1
Set rng = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
res = Application.Match(searchString, rng, 0)
'Application.Match returns error if nothing found
findString = Not IsError(res)
If findString Then
.Cells(1, "B").Value = rng.Cells(res, 1).Row
.Cells(1, "C").Value = searchString
End If
End With
End Function
I'm reasonably new to Excel Vba, but my limited understanding is that reading from cells is relatively slow. If I were doing this I would read all the values into an array, and carry out the same for loop as you have used, but on the array, rather than cell values.
To confirm, you could use VBAs Timer function to check speed.
Let me know if you'd like more detailed explanations of how to do this.
Here's how you can turn a range into an array (and vice versa). Step through this code with the Locals window turned on and watch what happens. You are particularly interested in the astrArray variable.
Sub ChangeArray()
'
Dim astrArray As Variant
'
' Dim astrArray
' that is, with no type specified
' is exactly equivalent
'
Dim lngIndex As Long
Dim strMessage As String
'
Range("A1").Value = "This"
Range("A2").Value = "is"
Range("A3").Value = "only"
Range("A4").Value = "a"
Range("A5").Value = "test"
astrArray = Range("A1:A5")
For lngIndex = 1 To 5
strMessage = strMessage & astrArray(lngIndex, 1) & " "
Select Case lngIndex
Case 1
astrArray(lngIndex, 1) = "No,"
Case 2
astrArray(lngIndex, 1) = "it's"
Case 3
astrArray(lngIndex, 1) = "actually"
Case 4
astrArray(lngIndex, 1) = "real"
Case 5
astrArray(lngIndex, 1) = "life"
End Select
Next lngIndex
MsgBox strMessage
Range("A1:A5") = astrArray
End Sub
A key requirement: to do this, the variable must be DIMmed Variant!
Another thing to pay attention to: the variable is two-dimensional, even though the range selected is one-dimensional.
I'm not entirely sure how to word this but, I have an Excel macro that enables a search functionality within my workbook. My issue is that I need the search to understand 'é' as 'e'. So that if I search for 'Belem', my result would come back with 'Belém'. How would I go about this? Thanks for any time and consideration.
Sub city()
If ActiveSheet.Name <> "City" Then Exit Sub
LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Sheets("Results").Range("3:10000").Delete
SearchTerm = Application.InputBox("What are you looking for?")
Application.ScreenUpdating = False
Range("W1") = SearchTerm
Range("W2:W" & LastRow).FormulaR1C1 = _
"=IF(ISERR(SEARCH(R1C23,RC[-22]&RC[-21]&RC[-20]&RC[-19]&RC[-18]&RC[-17]&RC[-16]&RC[-15]&RC[-15]&RC[-14]&RC[-13]&RC[-12]&RC[-11]&RC[-10]&RC[-9]&RC[-8]&RC[-7]&RC[-6]&RC[-5]&RC[-4]&RC[-3]&RC[-2]&RC[-1])),0,1)"
If WorksheetFunction.CountIf(Columns(23), 1) = 0 Then
Columns(23).Delete
Application.ScreenUpdating = True
MsgBox "None found."
Else
For Each Cell In Range("A2:A" & LastRow)
If Cell.Offset(, 22) = 1 Then
Cell.Resize(, 51).Copy Sheets("Results").Range("A" & Rows.Count).End(xlUp).Offset(1)
x = x + 1
End If
Next Cell
Columns(22).Delete
Application.ScreenUpdating = True
If x = 1 Then
MsgBox "1 matching record was copied to Search Results tab."
Else
MsgBox x & " matching records were copied to Search Results tab."
End If
End If
End Sub
You can modify the search parameter and then use the like operator as follows:
Sub city()
Dim rngResult As Range
Dim searchTerm As String, counter As Integer
Dim values As Variant, value As Variant
If ActiveSheet.Name <> "City" Then Exit Sub
'First Cell with the results
Set rngResult = <First cell of the result Range>
'Uses a variant array to get all values from the range. This speeds up the routine
values = <Area of Search>.Value
'Converts to lowercase to do a case insensitive search (e.g. Belem = belem)
searchTerm = LCase(Application.InputBox("What are you looking for?"))
If searchTerm = "" Then Exit Sub
' "§" is just a placeholder
searchTerm = Replace(searchTerm, "e", "§")
searchTerm = Replace(searchTerm, "é", "§")
searchTerm = Replace(searchTerm, "§", "[eé]")
Application.ScreenUpdating = False
counter = 0
For Each value In values
If LCase(value) Like searchTerm Then
rngResult = value
Set rngResult = rngResult.Offset(1, 0) 'Moves to the next line
counter = counter + 1
End If
Next value
If counter = 0 Then
MsgBox "None found."
Else
MsgBox "Found " & counter & " results"
'Do what you need to do with the results
End If
Application.ScreenUpdating = True
End Sub
All the results will be at the column of rngResult.
The code works by replacing "e" and "é" by "§" and then replacing "§" by "[eé]", (e.g. "bélem" -> "bél§m" -> "b§l§m" -> "b[eé]l[eé]m").
The like will match either "e" or "é" on that position. You can learn more about it here or in the help files. Here is a Example:
bélem Like "b[eé]l[eé]m" ' true
belem like "b[eé]l[eé]m" ' true
recife like "b[eé]l[eé]m" ' false
You can search more graphs by adding other criteria like:
'Like will match "a","á", "à" and "ã"
searchTerm = Replace(searchTerm, "a", "§")
searchTerm = Replace(searchTerm, "á", "§")
searchTerm = Replace(searchTerm, "à", "§")
searchTerm = Replace(searchTerm, "ã", "§")
searchTerm = Replace(searchTerm, "§", "[aáàã]")
This method has the advantage that you only need one "translation" in order to do comparisons. This can improve the performance if you have a large dataset
You can keep an array of all the characters you want to replace and what you want to replace them with. It's easier if you "search" your data a little differently that using that formula. Here's how I would do it.
Sub FindCity()
Dim shResults As Worksheet
Dim vaData As Variant
Dim i As Long, j As Long
Dim sSearchTerm As String
Dim sData As String
Dim rNext As Range
'Put all the data into an array
vaData = ActiveSheet.UsedRange.Value
'Get the search therm
sSearchTerm = Application.InputBox("What are you looking for?")
'Define and clear the results sheet
Set shResults = ActiveWorkbook.Worksheets("Results")
shResults.Range("A3").Resize(shResults.UsedRange.Rows.Count, 1).EntireRow.Delete
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
For j = LBound(vaData, 2) To UBound(vaData, 2)
'Get rid of diacritial characters
sData = LCase(Anglicize(vaData(i, j)))
'Look for a match
If InStr(1, sData, LCase(Anglicize(sSearchTerm))) > 0 Then
'Write the row to the next available row on Results
Set rNext = shResults.Cells(shResults.Rows.Count, 1).End(xlUp).Offset(1, 0)
rNext.Resize(1, UBound(vaData, 2)).Value = Application.Index(vaData, i, 0)
'Stop looking in that row after one match
Exit For
End If
Next j
Next i
End Sub
Public Function Anglicize(ByVal sInput As String) As String
Dim vaGood As Variant
Dim vaBad As Variant
Dim i As Long
Dim sReturn As String
'Replace any 'bad' characters with 'good' characters
vaGood = Split("S,Z,s,z,Y,A,A,A,A,A,A,C,E,E,E,E,I,I,I,I,D,N,O,O,O,O,O,U,U,U,U,Y,a,a,a,a,a,a,c,e,e,e,e,i,i,i,i,d,n,o,o,o,o,o,u,u,u,u,y,y", ",")
vaBad = Split("Š,Ž,š,ž,Ÿ,À,Á,Â,Ã,Ä,Å,Ç,È,É,Ê,Ë,Ì,Í,Î,Ï,Ð,Ñ,Ò,Ó,Ô,Õ,Ö,Ù,Ú,Û,Ü,Ý,à,á,â,ã,ä,å,ç,è,é,ê,ë,ì,í,î,ï,ð,ñ,ò,ó,ô,õ,ö,ù,ú,û,ü,ý,ÿ", ",")
sReturn = sInput
For i = LBound(vaBad) To UBound(vaBad)
sReturn = Replace$(sReturn, vaBad(i), vaGood(i))
Next i
Anglicize = sReturn
End Function
List of characters from Excel 2007 VBA Converting Accented Characters to Regular