I have an If Else which always triggers on the "If" line.
It compares strings from a table and which are pulled with a DLookup. I checked what the DLookup is returning with a textbox. I'm not sure if am comparing the strings well and have tried the "like" keyword.
Dim CB As Double
Dim Csize As Double
Dim DocCat As String
'CB Loop - Go through all customers in CArray and get the document letter corresponding to the document number in the textbox named SBBox
Dim CArray(1 To 5) As String
CArray(1) = "FF"
CArray(2) = "GG"
CArray(3) = "HH"
CArray(4) = "JJ"
CArray(5) = "DD"
Dim customer As Variant
For Each customer In CArray
'Get portion from customer table by corresponding the customer name with name in array.
Csize = Nz(DLookup("[portion]", "tblCustomer", "[sName] ='" & customer & "'"))
'get document letter from table customer depending on name from array. The table contaning the DocLetters is named the same as in the array (e.g. FF GG HH and so on)
DocCat = Nz(DLookup("[DocLetter]", customer, "[Doc Number]= '" & SBBox.Value & "'"))
'Doc Number contains Strings
'Use the DocCat to categoriez "bad", "good", "great" Letter. Here is my problem. It always tiggers the first "Then" statement even if the letter isn't correct.
If StrComp(DocCat, "A") Or StrComp(DocCat, "B") Or StrComp(DocCat, "C") Then
CB = 0
ElseIf StrComp(DocCat, "E") Or StrComp(DocCat, "F") or Null Then
CB = 0.3
Else: CB = 0.7
End If
'I have tried the "Like" keyword
if (DocCat Like "A" = True) or (DocCat Like "B" = True) or (DocCat Like "C" = True) Then
CB = 0
ElseIf (DocCat Like "E" = True) or (DocCat Like "F" = True) or Null Then
CB = 0.3
Else: CB = 0.7
EndIf
ElseIf StrComp(DocCat, "E") Or StrComp(DocCat, "F") or Null Then
You can't use Null this way, and StrComp returns 0 for a match, so:
If StrComp(DocCat, "A") = 0 Or StrComp(DocCat, "B") = 0 Or StrComp(DocCat, "C") = 0 Then
CB = 0
ElseIf StrComp(DocCat, "E") = 0 Or StrComp(DocCat, "F") = 0 or DocCat = "" Then
CB = 0.3
Else
CB = 0.7
End If
I have a text field Ran and I want to be able to update the field RanKeyNo5 (update query) with the numeric equivalent (2 digits) for a specified number of letters as they occur in the Ran field, i.e. the first 5 letters of the alphabet in the order that they occur in Ran.
For example, if Ran contains BFHCIEALGJDK, the answer would be 0203050104.
I put message boxes in the code to monitor the values, and it seemed to work, but the table doesn't get updated.
Query, 'update to':
KeyNo([Ran],5)
Public Function KeyNo(myStr As String, intLen As Integer) As String
Dim RandomString As String, strLetter As String, PosNo As Integer, LetSelect As String, LetNo As String, Count As Integer
RandomString = "00"
PosNo = 1
Count = Len(myStr)
'MsgBox myStr
Dim i As Long
For i = 1 To Count
LetSelect = Mid(myStr, PosNo, 1)
If LetSelect = "A" Then
LetNo = "01"
ElseIf LetSelect = "B" Then
LetNo = "02"
ElseIf LetSelect = "C" Then
LetNo = "03"
ElseIf LetSelect = "D" Then
LetNo = "04"
ElseIf LetSelect = "E" Then
LetNo = "05"
ElseIf LetSelect = "F" Then
LetNo = "06"
ElseIf LetSelect = "G" Then
LetNo = "07"
ElseIf LetSelect = "H" Then
LetNo = "08"
ElseIf LetSelect = "I" Then
LetNo = "09"
ElseIf LetSelect = "J" Then
LetNo = "10"
ElseIf LetSelect = "K" Then
LetNo = "11"
ElseIf LetSelect = "L" Then
LetNo = "12"
ElseIf LetSelect = "M" Then
LetNo = "13"
ElseIf LetSelect = "N" Then
LetNo = "14"
ElseIf LetSelect = "O" Then
LetNo = "15"
ElseIf LetSelect = "P" Then
LetNo = "16"
ElseIf LetSelect = "Q" Then
LetNo = "17"
ElseIf LetSelect = "R" Then
LetNo = "18"
ElseIf LetSelect = "S" Then
LetNo = "19"
ElseIf LetSelect = "T" Then
LetNo = "20"
ElseIf LetSelect = "U" Then
LetNo = "21"
ElseIf LetSelect = "V" Then
LetNo = "22"
ElseIf LetSelect = "W" Then
LetNo = "23"
ElseIf LetSelect = "X" Then
LetNo = "24"
ElseIf LetSelect = "Y" Then
LetNo = "25"
ElseIf LetSelect = "Z" Then
LetNo = "26"
End If
If Val(LetNo) <= intLen Then
RandomString = RandomString & LetNo
' MsgBox RandomString
End If
PosNo = PosNo + 1
Next
RandomString = Mid(RandomString, 3, intLen * 2)
End Function
It returns nothing because function is not set to return anything. Last line should be:
KeyNo = Mid(RandomString, 3, intLen * 2)
As #June7 correctly notes in their answer, the reason that your function does not return anything is because the symbol KeyNo is initialised as a null string ("") by virtue of the fact that the function is defined to return a string (Function KeyNo ... As String), however, you don't redefine KeyNo to anything else within the function, hence, the function will always return an empty string.
However, for the task that you have described:
I want to be able to update the field RanKeyNo5 with the numeric equivalent (2 digits) for a specified number of letters as they occur in the Ran field.
The code could be greatly simplified - for example, consider the following approach:
Function KeyNo(strStr As String, intLen As Integer) As String
Dim i As Integer
Dim a As Integer
For i = 1 To Len(strStr)
a = Asc(Mid(strStr, i, 1)) - 64
If a <= intLen Then KeyNo = KeyNo & Format(a, "00")
Next i
End Function
?KeyNo("BFHCIEALGJDK",5)
0203050104
It's my first time posting here. I am currently exploring VBA and I wanted to make a macro that formats phone numbers and translates it into a standard format. All special characters other that numbers and letters should be removed. I'm so sorry for my english is not that good. Here is an example.
The scenario must look like this, I select a range,
8009228080
(900) (CAT) BABA
(+1) (900) (289) (9000)
900.900.9000
then I click the button where the macro is assigned then it goes like this
800-922-8080
900-228-2222
900-289-9000
900-900-9000
The output must be only ###-###-#### (3 numbers ' - ' 3 numbers ' - ' 4 numbers)
Letter must be translated into following
ABC = 2, DEF = 3, GHI = 4, JKL = 5, MNO = 6, PQRS = 7, TUV = 8, WXYZ = 9
I tried looking it up and here is my try:
Sub PhoneFormat()
Dim StSel As Range
Dim EndSel As Range
On Error Resume Next
xTitleId = "Format Phone Numbers"
Set EndSel = Application.Selection
Set EndSel = Application.InputBox("Range", xTitleId, EndSel.Address, Type:=8)
I want to change this part as I want to select the range first, then click the button then the macro is applied
For Each StSel In EndSel
StSel.Value = Application.WorksheetFunction.Substitute(StSel.Value, "+", "")
StSel.Value = Application.WorksheetFunction.Substitute(StSel.Value, "+1", "")
StSel.Value = Application.WorksheetFunction.Substitute(StSel.Value, "-", "")
StSel.Value = Application.WorksheetFunction.Substitute(StSel.Value, ".", "")
StSel.Value = Application.WorksheetFunction.Substitute(StSel.Value, "(", "")
StSel.Value = Application.WorksheetFunction.Substitute(StSel.Value, ")", "")
StSel.Value = Application.WorksheetFunction.Substitute(StSel.Value, " ", "")
If (Len(StSel) > 10) Then
StSel = Right(StSel, 10)
End If
StSel = Left(StSel, 3) & "-" & Mid(StSel, 4, 3) & "-" & Right(StSel, 4)
Next
End Sub
I think this could be optimized into much simplier code but I can't do it. This code also can't replace letters to numbers. Thanks in advance an I hope anyone would answer this.
Here is an example how you could do it with Regular Expressions:
Option Explicit
Public Sub test()
Debug.Print FormatWithRegEx("(900) (CAT) BABA")
Debug.Print FormatWithRegEx("(+1) (900) (289) (9000)")
Debug.Print FormatWithRegEx("900.900.9000")
Debug.Print ReplaceCharactersWithRegEx(FormatWithRegEx("(900) (CAT) BABA"))
'or dircetly implement ReplaceCharactersWithRegEx in FormatWithRegEx
End Sub
Public Function FormatWithRegEx(InputString As String) As String
Dim objRegEx As Object
Set objRegEx = CreateObject("vbscript.regexp")
Dim arrPatterns() As Variant
arrPatterns = Array( _
"([A-Z0-9]{10})", _
"\(?([A-Z0-9]{3})\)? \(?([A-Z0-9]{3})\)? \(?([A-Z0-9]{4})\)?", _
"([A-Z0-9]{3})\.([A-Z0-9]{3})\.([A-Z0-9]{4})" _
)
Dim Pattern As Variant
For Each Pattern In arrPatterns
With objRegEx
.Global = True
.IgnoreCase = True
.MultiLine = False
.Pattern = Pattern
Dim objMatches As Object
Set objMatches = .Execute(InputString)
End With
If objMatches.Count = 1 Then
With objMatches(0)
If .SubMatches.Count = 3 Then
FormatWithRegEx= .SubMatches(0) & "-" & .SubMatches(1) & "-" & .SubMatches(2)
End If
End With
End If
If FormatWithRegEx <> vbNullString Then Exit For
Next Pattern
'to implement ReplaceCharactersWithRegEx uncomment …
'FormatWithRegEx = ReplaceCharactersWithRegEx(FormatWithRegEx)
End Function
It recognizes the 3 given patterns in the test. Translation from characters into numbers still has to be done.
Here is a pure RegEx Replace example
Public Function ReplaceCharactersWithRegEx(InputString As String) As String
InputString = RegExReplace(InputString, "[ABC]{1}", "2")
InputString = RegExReplace(InputString, "[DEF]{1}", "3")
InputString = RegExReplace(InputString, "[GHI]{1}", "4")
InputString = RegExReplace(InputString, "[JKL]{1}", "5")
InputString = RegExReplace(InputString, "[MNO]{1}", "6")
InputString = RegExReplace(InputString, "[PQRS]{1}", "7")
InputString = RegExReplace(InputString, "[TUV]{1}", "8")
InputString = RegExReplace(InputString, "[WXYZ]{1}", "9")
ReplaceCharactersWithRegEx = InputString
End Function
Private Function RegExReplace(InputString, Pattern, Replace) As String
Dim objRegEx As Object
Set objRegEx = CreateObject("vbscript.regexp")
With objRegEx
.Global = True
.IgnoreCase = True
.MultiLine = False
.Pattern = Pattern
Dim objMatches As Object
Set objMatches = .Execute(InputString)
End With
RegExReplace = objRegEx.Replace(InputString, Replace)
End Function
//Edit
made it case insensitive with .IgnoreCase = True
//Edit2
A Selection Loop Example
Dim cl As Range
For Each cl In Selection 'instead of Selection you can also use a defined Range("A1:A50")
Dim FormattedValue As String
FormattedValue = FormatWithRegEx(cl.value)
If FormattedValue <> vbNullString Then 'don't delete if formatting wasn't successful
cl.value = FormatWithRegEx(cl.value)
End If
Next cl
Taking PEH's answer and adding the Conversion of Letters to Numbers:
Option Explicit
Public Sub test()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim rng As Range
Dim cell As Range
Set rng = Selection
For Each cell In rng
cell.Value = ConvertLetters(FormatWithRegEx(cell.Value))
Next
End Sub
Public Function ConvertLetters(FormattedString As String) As String
Dim J As Long, Digit As Variant
For J = 1 To Len(FormattedString)
Digit = UCase(Mid(FormattedString, J, 1))
Select Case Digit
Case "A" To "P"
Digit = Chr((Asc(Digit) + 1) \ 3 + 28)
Case "Q"
Digit = "7"
Case "R" To "Y"
Digit = Chr(Asc(Digit) \ 3 + 28)
Case "Z"
Digit = "9"
End Select
Mid(FormattedString, J, 1) = Digit
Next J
ConvertLetters = FormattedString
End Function
Public Function FormatWithRegEx(InputString As String) As String
Dim objRegEx As Object
Set objRegEx = CreateObject("vbscript.regexp")
Dim arrPatterns() As Variant
arrPatterns = Array( _
"\(([a-zA-Z0-9]{3})\) \(([a-zA-Z0-9]{3})\) ([a-zA-Z0-9]{4})", _
"\(([a-zA-Z0-9]{3})\) \(([a-zA-Z0-9]{3})\) \(([a-zA-Z0-9]{4})\)", _
"([a-zA-Z0-9]{3})\.([a-zA-Z0-9]{3})\.([a-zA-Z0-9]{4})" _
)
Dim Pattern As Variant
For Each Pattern In arrPatterns
With objRegEx
.Global = True
.IgnoreCase = True
.MultiLine = False
.Pattern = Pattern
Dim objMatches As Object
Set objMatches = .Execute(InputString)
End With
If objMatches.Count = 1 Then
With objMatches(0)
If .SubMatches.Count = 3 Then
FormatWithRegEx = .SubMatches(0) & "-" & .SubMatches(1) & "-" & .SubMatches(2)
End If
End With
End If
If FormatWithRegEx <> vbNullString Then Exit For
Next Pattern
End Function
UPDATE:
The following will format your phone numbers as expressed in your comments (taking Thom's answer and adding the Selection):
Sub PhoneFormat()
Dim myLen As Long
Dim i As Long
Dim myNum As String
Dim newNum
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim rng As Range
Dim cell As Range
Set rng = Selection
For Each cell In rng
' Loop through characters, converting values
If Len(cell.Value) > 0 Then
For i = 1 To Len(cell.Value)
Select Case Mid(cell.Value, i, 1)
Case "0"
myNum = "0"
Case "1"
myNum = "1"
Case "2"
myNum = "2"
Case "3"
myNum = "3"
Case "4"
myNum = "4"
Case "5"
myNum = "5"
Case "6"
myNum = "6"
Case "7"
myNum = "7"
Case "8"
myNum = "8"
Case "9"
myNum = "9"
Case "A", "B", "C", "a", "b", "c"
myNum = "2"
Case "D", "E", "F", "d", "e", "f"
myNum = "3"
Case "G", "H", "I", "g", "h", "i"
myNum = "4"
Case "J", "K", "L", "j", "k", "l"
myNum = "5"
Case "M", "N", "O", "m", "n", "o"
myNum = "6"
Case "P", "Q", "R", "S", "p", "q", "r", "s"
myNum = "7"
Case "T", "U", "V", "t", "u", "v"
myNum = "8"
Case "W", "X", "Y", "Z", "w", "x", "y", "z"
myNum = "9"
Case " ", "-", "."
myNum = "-"
Case Else
myNum = ""
End Select
newNum = newNum & myNum
Next i
End If
cell.Value = Right(newNum, 12)
Next
End Sub
I have now amended the script to work with a selected range and it will also convert all given examples.
It is simple to read and amend for other purposes which maybe useful to somebody, that is why I am posting it.
The script uses Case Else to remove characters that are not defined, converting the ones that are required.
Sub PhoneFormatRange()
Dim myLen As Long
Dim i As Long
Dim myNum As String
Dim newNum As String
Dim selectedRng As Range
Dim celRng As Range
Dim strLeft As String
Dim strMid As String
Dim strRight As String
' Find the Selected Range and for each cell in the selected range run the cade and repeat.
Set selectedRng = Application.Selection
For Each celRng In selectedRng.Cells
' Convert Cell value to an array
myLen = Len(celRng.Value)
ReDim Carray(Len(celRng.Value))
For i = 0 To myLen
Carray(i) = Mid(celRng.Value, i + 1, 1)
Next
' Loop through array, converting values
If myLen > 0 Then
For i = 0 To myLen
Select Case Carray(i)
Case "0"
myNum = "0"
Case "1"
myNum = "1"
Case "2"
myNum = "2"
Case "3"
myNum = "3"
Case "4"
myNum = "4"
Case "5"
myNum = "5"
Case "6"
myNum = "6"
Case "7"
myNum = "7"
Case "8"
myNum = "8"
Case "9"
myNum = "9"
Case "A", "B", "C", "a", "b", "c"
myNum = "2"
Case "D", "E", "F", "d", "e", "f"
myNum = "3"
Case "G", "H", "I", "g", "h", "i"
myNum = "4"
Case "J", "K", "L", "j", "k", "l"
myNum = "5"
Case "M", "N", "O", "m", "n", "o"
myNum = "6"
Case "P", "Q", "R", "S", "p", "q", "r", "s"
myNum = "7"
Case "T", "U", "V", "t", "u", "v"
myNum = "8"
Case "W", "X", "Y", "Z", "w", "x", "y", "z"
myNum = "9"
Case " ", "-", "."
myNum = "-"
Case Else
myNum = ""
End Select
newNum = newNum & myNum
Next i
End If
' Check the length of the string and if it requals 10 then add the hypens
If Len(newNum) = 10 Then
strLeft = Left(newNum, 3)
strMid = Mid(newNum, 4, 3)
strRight = Right(newNum, 4)
newNum = strLeft & "-" & strMid & "-" & strRight
End If
' Set the cell value within the range to 12 right most characters of the string
celRng.Value = Right(newNum, 12)
' Clear newNum before repeating
newNum = ""
' Go back to celRng and repeat until all the cells within the selection is complete
Next celRng
End Sub
I was also writing a regular expression as PEH did. But my approach was a bit different. Only posting it because it was fun to code this piece and it maybe helps.
I also used Xabiers ConvertLetters function because it does a good job and the code is a really good approach.
My approach to the regular expression was to match ALL criterias in one expression. So the pattern I defined finds all your defined possibilities. This forced me to make some extra replacements though so I extended Xabiers code a bit.
Sub correctNumbers()
Dim i As Long, J As Long
Dim sEXP As String
Dim rng As Range
Dim oRegEx As Object, oMatch As Object
' create object for regular expressions
Set oRegEx = CreateObject("vbscript.regexp")
' supposed you have a sheet called "Sheet1" - change sheetname and range according to your needs
Set rng = ThisWorkbook.Sheets("Sheet1").Range("A2:A4")
' run through every entry in range
For i = 1 To rng.Rows.Count
With oRegEx
.Global = True
.IgnoreCase = False
' define pattern as desribed by you needs
.Pattern = "([\(]?[0-9]{3}[\)]?[\s\.]?[\(]?[A-Z0-9]{3}[\)]?[\s\.]?[\(]?[A-Z0-9]{4}[\)]?)"
Set oMatch = .Execute(rng(i, 1).Value)
If oMatch.Count <> 0 Then
sEXP = oMatch(0)
If Len(sEXP) = 10 Then
sEXP = Left(sEXP, 3) & "-" & Right(Left(sEXP, 6), 3) & "-" & Right(sEXP, 4)
Else
sEXP = ConvertLetters(oMatch(0))
End If
Else
sEXP = ""
End If
End With
' write result in column B
ThisWorkbook.Sheets("Sheet1").Range("B" & i + 1).Value = sEXP
Next i
End Sub
Public Function ConvertLetters(FormattedString As String) As String
Dim J As Long, Digit As Variant
For J = 1 To Len(FormattedString)
Digit = UCase(Mid(FormattedString, J, 1))
Select Case Digit
Case "A" To "P"
Digit = Chr((Asc(Digit) + 1) \ 3 + 28)
Case "Q"
Digit = "7" 'May want to change
Case "R" To "Y"
Digit = Chr(Asc(Digit) \ 3 + 28)
Case "Z"
Digit = "9" 'May want to change
' added as my regular expression finds complete number including dots, spaces and braces
Case ".", " "
Digit = "-"
End Select
Mid(FormattedString, J, 1) = Digit
Next J
' added repalce as my regular expression finds complete number including dots, spaces and braces
ConvertLetters = Replace(Replace(FormattedString, "(", ""), ")", "")
End Function
I have a macro taking two spreadsheets and performing a look up. I need to be able to take the value selected by the user from a combobox (ComboBox1.value), and assign a column reference to then check to see if the column is empty, before proceeding. This is to prevent the user from selecting a month column within a spreadsheet, and providing an update for a month that has already been updated. I will then alert them, and they can choose how to proceed.
The combobox contains a list of all 12 months. I need to set a value to be the column reference for their selection, and if that column is blank (starting from A2 to last entry in column, or if there is any value in any cell starting at row 2 to end.. whichever makes the most sense), alert them.
This sheet has over 20K rows. I can't pick just one to reference, as it is plausible it could have blanks, thus why I am checking for a value in entire column.
I for the love of Pete, in all my newbie glory, after searching to the interwebz, cannot make this happen...
Code below is not giving an error, but it also not working properly. I have a test sheet with values in it for April, and it doesn't alert, it goes to next action.
My block of code where I am trying to do this looks like ...
Dim UpdateMonthColumn As String
If ABCMatrixMonthSelect.ComboBox1.value = "January" Then
UpdateMonthColumn = "U"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "February" Then
UpdateMonthColumn = "W"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "March" Then
UpdateMonthColumn = "Y"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "April" Then
UpdateMonthColumn = "C"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "May" Then
UpdateMonthColumn = "E"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "June" Then
UpdateMonthColumn = "G"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "July" Then
UpdateMonthColumn = "I"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "August" Then
UpdateMonthColumn = "K"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "September" Then
UpdateMonthColumn = "M"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "October" Then
UpdateMonthColumn = "O"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "November" Then
UpdateMonthColumn = "Q"
ElseIf ABCMatrixMonthSelect.ComboBox1.value = "December" Then
UpdateMonthColumn = "S"
End If
If WorksheetFunction.CountA(Columns(UpdateMonthColumn)) = 0 Then
'If WorksheetFunction.CountA(Range("Sheet 1[UpdateMonthColumn]")) <> 0 Then
Msgbox12 = Msgbox("The column you will place the ABC Count within for " &
ABCMatrixMonthSelect.ComboBox1 & "is not empty." & vbCr & " Do you still
wish to proceed with an update for " & ABCMatrixMonthSelect.ComboBox1 & "?"
& vbCr & "Select Yes to proceed and update with new values." & vbCr
& "Select No to return to drop down list and chose a different month." &
vbCr & "Select Cancel to return to ABC Matrix Main Menu.", vbQuestion Or
vbYesNoCancel, "ABC Matrix Macro")
If Msgbox12 = vbYes Then GoTo SelectFile2:
If Msgbox12 = vbNo Then ActiveWorkbook.Close
GoTo SelectMonth:
If Msgbox12 = vbCancel Then
Msgbox "ABC Count update cancelled by user!" & vbCr & vbCr & "Returning
to ABC Matrix Macro Main Menu.", vbCritical, "ABC Matrix Macro Alert!"
With ABCMatrixMainMenu
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
.Show
Exit Sub
End With
End If
Else
Dim rng As Range, sht As WorkSheet
Set sht = thisworkbook.sheets("Sheet1")
'select case is cleaner than a long If Then block
Select Case ABCMatrixMonthSelect.ComboBox1.value
Case "January": UpdateMonthColumn = "U"
Case "February": UpdateMonthColumn = "W"
Case "March": UpdateMonthColumn = "Y"
'...etc
End Select
Set rng = sht.Range(sht.Cells(2,UpdateMonthColumn), _
sht.Cells(sht.rows.count, UpdateMonthColumn))
If WorksheetFunction.CountA(rng) = 0 Then
'OK
End If
I am trying to write a VBA script to sort a cell into a group of ranges split by the first letter. Namely I want to write a glossary/dictionary type thing and I want to be able to write a word, and have it automatically sort into the set of lists.
I have a few problems with this, primarily because I have no experience writing VBA scripts and little other programming knowledge. Some problems I came here to solve:
How do I assign these ranges more efficiently (notice they are all 3 columns apart)
How do I select the cell I want to sort into my array
This is what I was able to do with what I found:
Sub Sort()
'
' Sortme Macro
'
Private Sub Worksheet_Change(ByVal Target As Range)
ColA = Range(a6, a1048576)
ColB = Range(e6, e1048576)
ColC = Range(h6, h1048576)
ColD = Range(k6, k1048576)
ColE = Range(n6, n1048576)
ColF = Range(q6, q1048576)
ColG = Range(t6, t1048576)
ColH = Range(w6, w1048576)
ColI = Range(z6, z1048576)
ColJ = Range(ac6, ac1048576)
ColK = Range(af6, af1048576)
ColL = Range(ai6, ai1048576)
ColM = Range(al6, al1048576)
ColN = Range(ao6, ao1048576)
ColO = Range(ar6, ar1048576)
ColP = Range(au6, au1048576)
ColQ = Range(ax6, ax1048576)
ColR = Range(ba6, bb1048576)
ColS = Range(bd6, bd1048576)
ColT = Range(bg6, bg1048576)
ColU = Range(bj6, bj1048576)
ColV = Range(bm6, bm1048576)
ColW = Range(bp6, bp1048576)
ColX = Range(bs6, bs1048576)
ColY = Range(bv6, bv1048576)
ColZ = Range(by6, by1048576)
On Error Resume Next
Right here I want to know how to select a cell, also for loops ? :
For left(range(Thiscell))
If Not Intersect(Target, Range("ColA")) Is Nothing Then
Range(ColA).Sort Key1:=Range("A2"), _
Order1:=xlAscending, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End For
Is this how I end a for loop in this language?
End Sub
'
End Sub
This is what i have:
![my excel sheet before any vba works and I have to type everything in by hand]:[http://imgur.com/K5diRM9]
Sorry if this doesn't really make sense but thanks in advance anyway :)
Type a word into A1 of your sheet named "Dictionary". Then run this macro. It will put the word into the correct alphabetized column and then sort that column if needed. The words begin on row 6, which is where I think you want them to start. you can adjust it to accept the word f4rom an input box or add a list of words from another worksheet column.
Sub putWordInAlphebeticalColumn()
Dim columnArr, wordToAlphebetize As String, lastUsedRw As Long
Dim i As Integer, isAlpha As Boolean, firstLetter As String
Dim colNumber As Integer
columnArr = 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")
wordToAlphebetize = Sheets("Dictionary").Range("A1").Value
If Len(wordToAlphebetize) > 0 Then ' Determine if string is all alpha characters
For i = 1 To Len(Trim(wordToAlphebetize))
Select Case Asc(Mid(wordToAlphebetize, i, 1))
Case 65 To 90, 97 To 122
isAlpha = True
Case Else
If i > 1 And Mid(Trim(wordToAlphebetize), i, 1) = "-" Then
isAlpha = True
Else
isAlpha = False
MsgBox "Word contains non-alpha character(s)"
Sheets("Dictionary").Range("A1").Value = ""
Exit Sub
End If
End Select
Next i
End If
firstLetter = Mid(wordToAlphebetize, 1, 1)
For i = 0 To 26
If UCase(firstLetter) = columnArr(i) Then
colNumber = i
Exit For
End If
Next i
lastUsedRw = Sheets("Dictionary").Range(columnArr(colNumber) & Rows.Count).End(xlUp).Row
With Sheets("Dictionary").Range(columnArr(colNumber) & "6:" & columnArr(colNumber) & lastUsedRw + 6)
Set c = .Find(LCase(wordToAlphebetize), LookIn:=xlValues)
If Not c Is Nothing Then
MsgBox "Word already exists"
Sheets("Dictionary").Range("A1").Value = ""
Exit Sub
Else
If Sheets("Dictionary").Range(columnArr(colNumber) & "6").Value = "" Then
Sheets("Dictionary").Range(columnArr(colNumber) & "6").Value = wordToAlphebetize
Else
Sheets("Dictionary").Range(columnArr(colNumber) & lastUsedRw + 1).Value = wordToAlphebetize
End If
lastUsedRw = Sheets("Dictionary").Range(columnArr(colNumber) & Rows.Count).End(xlUp).Row
If lastUsedRw > 6 Then
Range(columnArr(colNumber) & "6:" & columnArr(colNumber) & lastUsedRw).Select
Worksheets("Dictionary").Sort.SortFields.Clear
Worksheets("Dictionary").Sort.SortFields.Add Key:=Range(columnArr(colNumber) & "6") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets("Dictionary").Sort
.SetRange Range(columnArr(colNumber) & "6:" & columnArr(colNumber) & lastUsedRw)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
End If
End With
End Sub