I've got a porblem with the first line of my code, the thing is that i cant fix it for some reason.
Sub Main(numgen as Integer, letras as String, letra as String, celda as String)
Call coincidir
Dim numgen As Integer
numgen = 0
numgen = coincidir("Total general; A8:Z8; 0")
numgen = numgen + 1
Dim letras(1 To 25) As String
letras(1) = "A"
letras(2) = "B"
letras(3) = "C"
letras(4) = "D"
letras(5) = "E"
letras(6) = "F"
letras(7) = "G"
letras(8) = "H"
letras(9) = "I"
letras(10) = "J"
letras(11) = "K"
letras(12) = "L"
letras(13) = "M"
letras(14) = "N"
letras(15) = "O"
letras(16) = "P"
letras(17) = "Q"
letras(18) = "R"
letras(19) = "S"
letras(20) = "T"
letras(21) = "U"
letras(22) = "V"
letras(23) = "W"
letras(24) = "Y"
letras(25) = "Z"
Dim letra As String
letra = "w"
letras(numgen) = letra
Dim celda As String
celda = letra + "8"
Range("celda").Select
ActiveCell.FormulaR1C1 = "Comisión"
End Sub
Quite some errors in your code
Remove Dim numgen As Integer (already declared in first line)
You are populating one variable three times right after each other while it can be done in one row
Remove Dim letra As String after you already populated the array
Remove Dim celda As String (already declared in first line)
Remove Dim letras As String in first line
Avoid selecting or activating ranges
For some reason you're populating a range with a formula that's just a one-word string
should look something like:
Sub Main(numgen as Integer, letra as String, celda as String)
Dim letras(1 To 25) as String
Call coincidir
numgen = coincidir("Total general; A8:Z8; 0") + 1
''' ommitted
letra = "w"
letras(numgen) = letra
celda = letra + "8"
Workbooks(REF).Sheets(REF).Range("celda").Value= "Comisión"
End Sub
Doing something along the lines of Sub test(sheetname As String, Nr As Long) is usually done when you're calling the sub and you want to pass values to it.
For example:
Sub test()
i = Range("A1").Value
str = "Sheet3"
anothersub sheetname:= str, Nr:= i
End Sub
Sub anothersub(sheetname As String, Nr As Long)
Dim sht As Worksheet
Set sht = Sheets(sheetname)
For i = 0 To Nr
MsgBox i
Next i
End Sub
You're now declaring variables twice, which results in errors
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 am trying to search for special characters in a string.
If the special character exists in the string then the code would return a false to the adjacent cell.
Dim arr(5)
arr(1) = "19"
arr(2) = "26"
arr(3) = "29"
arr(4) = "32"
arr(5) = "50"
'control characters check
For n = 1 To 5
For x = 1 To 41
If InStr(1, Range("b" & arr(n)), Chr(x)) = 0 Then
For y = 123 To 255
If InStr(Range("b" & arr(n)).Value, Chr(y)) > 0 Then
Range("e" & arr(n)).Value = "FALSE"
Exit For
Else
Range("e" & arr(n)).Value = "TRUE"
End If
Next y
Else
Range("e" & arr(n)).Value = "FALSE"
Exit For
End If
Next x
Next n
My problem is, just looping a few times took quite a long time, is there a faster way to loop through all the data saving more time?
An example of the string data in the cell is : TY56D-CAT131BP342AC46-eL-W-00
Try this:
Sub Test()
Dim arr(5) As String
Dim iLen As Integer, strV As String
Dim Found As Boolean: Found = False
Dim Test As Variant
arr(1) = "19"
arr(2) = "26"
arr(3) = "29"
arr(4) = "32"
arr(5) = "50"
For x = 1 To 5
iLen = Len(Range("B" & arr(x)).Value)
strV = Range("B" & arr(x)).Value
For i = 1 To iLen
Select Case Asc(Mid$(strV, i, 1))
Case 1 To 41, 123 To 255
Found = True
Exit For
End Select
Next i
If Found = False Then
Range("E" & arr(x)).Value = "TRUE"
Else
Found = False
Range("E" & arr(x)).Value = "FALSE"
End If
Next x
End Sub
Calculation time is nearly instant. What differs to your method is, that i go through every characters and then check if its allowed or not. In this case the Select Case can do this much quicker than a for loop for every unallowed char.
It looks like you're being slowed down a lot by referring to
Range("b" & arr(n)).Value
potentially up to 120+ times in the loop (which is itself nested in other loops)
What should immediately improve the speed of your macro is to transfer the Range value to a variable before this loop, for example:
dim search_string as string
search_string = Range("b" & arr(n)).Value
For y = 123 To 255
If InStr(search_string, Chr(y)) > 0 Then
Range("e" & arr(n)).Value = "FALSE"
You'd also save a bit of time converting your whole search range to an array and working on that, but that would take more work, whereas this is a quick change you can make which should drastically improve performance
Try this:
Sub CheckCharacters()
Dim cl(5) As Integer, n As Integer
cls = Array(19, 26, 29, 32, 50)
For n = 0 To 4
If IsValidString(Range("B" & cls(n))) Then
Range("B" & cls(n)).Offset(0, 3) = "TRUE"
Else
Range("B" & cls(n)).Offset(0, 3) = "FALSE"
End if
Next n
End Sub
Function IsValidString(str As String) As Boolean
Dim objRegEx As Object
Set objRegEx = CreateObject("vbscript.regexp")
objRegEx.Pattern = "^[\x2a-\x7a]+"
objRegEx.Global = True
objRegEx.IgnoreCase = True
IsValidString = objRegEx.test(str)
End Function
The important bit is:
"^[\x2a-\x7a]+"
This is a Regex that is only TRUE if the string only contains characters between ASCII values 42 and 122 (which is what you want).
I need the location of max value (one column) or address, so i can locate two cells left of the max value cell. next is finding the higher value of the two new cells and dividing the higher value with the max value. last step is returning the value to sheet "List1". that s the basic logic :)
thx for any help
the locating of max value and locating cells left of it, that is my main concern.
i cant figure it out. been looking for it but cant get it to work.
Sub DoIt()
'ONE MAIN SHEET (List1)
'MORE SECONDARY SHEETS WHERE DATA FOR MAX VALUE IS
Dim strSheet As String
Dim rng As Range
Dim dblMax As Double
Dim r As Range
i = 4
j = 8
g = 4
h = 20
s = 22
Dim cell As Range
Dim col, row
Do While Cells(i, j).Value <> ""
strSheet = Sheets(1).Cells(i, j)
Sheets(strSheet).Activate
'w = 2
'e = 27
'a = 2
'Do While Cells(a, s).Value >= "0"
'Range("AA1") = "IT WORKS"
'Cells(w, e) = Cells(a, s).Value
'a = a + 1
'w = w + 1
'Loop
Set rng = Sheets(strSheet).Range("V2:V8761")
dblMax = Application.WorksheetFunction.Max(rng)
'CODE FOR MAX VALUE LOCATION
'LOCATING TWO LEFT CELLS OF LOCATION MAX VALUE CELL
'DETERMINING THE HIGHER VALUE
'DIVIDING
Range("Z2") = dblMax 'CONTROL
i = i + 1
Range("Z1") = "IT WORKS" 'CONTROL
Sheets("List1").Activate
Cells(g, h) = "AAA" 'result of higher value cell by max value cell
g = g + 1
Loop
End Sub
thx for help i did it. code is not refind. here is the code:
Sub DoIt()
Dim strSheet As String
Dim rng As Range
Dim dblMax As Double
Dim r As Range
Dim dely As Double
i = 4
j = 8
g = 4
h = 20
l = 21
s = 22
Dim cell As Range
Dim col, row
Do While Cells(i, j).Value <> ""
strSheet = Sheets(1).Cells(i, j)
Sheets(strSheet).Activate 'error on no strsheet
w = 2
e = 27
a = 2
sumall = Application.Sum(Range("v2:v9000"))
'Do While Cells(a, s).Value >= "0"
'Range("AA1") = "nekaj dela"
'Cells(w, e) = Cells(a, s).Value
'a = a + 1
'w = w + 1
'Loop
Set rng = Sheets(strSheet).Range("V2:V9000")
dblMax = Application.WorksheetFunction.Max(rng)
mmm = Application.WorksheetFunction.Match(dblMax, Sheets(strSheet).Range("v:v"), 0)
positionRange = Sheets(strSheet).Range("v:v")
'iii = Application.WorksheetFunction.Index(positionRange, mmm)
'ooo = mmm.Offset(0, -1)
sum1 = Cells(mmm, 12)
sum2 = Cells(mmm, 21)
If sum1 > sum2 Then
'sumall = Application.Sum(Range("l2:l8761"))
PLDP = sumall / 365
dely = sum1 / PLDP * 100
smer = "1"
Else
'sumall = Application.Sum(Range("u2:u8761"))
PLDP = sumall / 365
dely = sum2 / PLDP * 100
smer = "2"
End If
'Range("AA2") = iii
Range("AB2") = sum1
Range("AC2") = sum2
Range("ad2") = dely
Range("ae2") = sumall
Range("af2") = PLDP
Range("Z2") = dblMax 'test cell
i = i + 1
Range("Z1") = "IT WORKS"
Sheets("List1").Activate
Cells(g, h) = smer
Cells(g, l) = dely
g = g + 1
Loop
End Sub
I am performing a keyword search (looping through an Excel column, looking for keywords contained in another spreadsheet, and assigning values to another column in the first spreadsheet if they are found). I'm doing this by making use of for loops and if - else statements, and it's proving to be rather slow. The keywords sheet has three columns in which you can enter keywords, and one column used to assign a value. The idea is that the text being scanned should contain all keywords entered in these keyword columns if the value is to be assigned. Placing a "-" before the keyword means that the value should only be assigned if the scanned text does not contain the keyword indicated. See the code below for the method used. The focus of my question in the efficiency of it.
Dim intLoopKeywordsRows As Integer
Dim intLoopDataShortTextRows As Integer
Dim strDataShortText As String
Dim strKeyword_A As String
Dim strKeyword_B As String
Dim strKeyword_C As String
Dim strCheck_B As String
Dim strCheck_C As String
Dim lastRow
Dim i As Integer
lastRow = Data.Cells(Rows.Count, 1).End(xlUp).Row
For intLoopKeywordsRows = 2 To lastRow
For intLoopDataShortTextRows = 2 To lastRow
'==================================================================================
'==================================================================================
If Data.Range("S" & intLoopDataShortTextRows) = "" Then '===========only if column S is blank
strDataShortText = Trim(UCase(Data.Range("G" & intLoopDataShortTextRows)))
strKeyword_A = UCase(wsKeywords.Range("A" & intLoopKeywordsRows))
strCheck_B = ""
If Left(wsKeywords.Range("B" & intLoopKeywordsRows), 1) = "-" Then
strCheck_B = "Neg"
strKeyword_B = UCase(Right(wsKeywords.Range("B" & intLoopKeywordsRows), Len(wsKeywords.Range("B" & intLoopKeywordsRows)) - 1))
ElseIf wsKeywords.Range("B" & intLoopKeywordsRows) <> "" Then
strCheck_B = "Pos"
strKeyword_B = UCase(wsKeywords.Range("B" & intLoopKeywordsRows))
End If
strCheck_C = ""
If Left(wsKeywords.Range("C" & intLoopKeywordsRows), 1) = "-" Then
strCheck_C = "Neg"
strKeyword_C = UCase(Right(wsKeywords.Range("C" & intLoopKeywordsRows), Len(wsKeywords.Range("C" & intLoopKeywordsRows)) - 1))
ElseIf wsKeywords.Range("C" & intLoopKeywordsRows) <> "" Then
strCheck_C = "Pos"
strKeyword_C = UCase(wsKeywords.Range("C" & intLoopKeywordsRows))
End If
Dim Check_JumpLoop As Integer
Check_JumpLoop = 0
'================if negative values found then go to next Data Text======================
If (strCheck_B = "Neg" And InStr(strDataShortText, strKeyword_B) > 0) Or (strCheck_C = "Neg" And InStr(strDataShortText, strKeyword_C) > 0) Then
Check_JumpLoop = 1
End If
'########################################################################################
'========================================================================================
If Check_JumpLoop = 0 Then
If strCheck_B = "Pos" And strCheck_C = "Pos" Then
If InStr(strDataShortText, strKeyword_A) > 0 And InStr(strDataShortText, strKeyword_B) > 0 And InStr(strDataShortText, strKeyword_C) > 0 Then
Data.Range("S" & intLoopDataShortTextRows) = wsKeywords.Range("E" & intLoopKeywordsRows)
End If
ElseIf strCheck_B = "Pos" And strCheck_C <> "Pos" Then
If InStr(strDataShortText, strKeyword_A) > 0 And InStr(strDataShortText, strKeyword_B) > 0 Then
Data.Range("S" & intLoopDataShortTextRows) = wsKeywords.Range("E" & intLoopKeywordsRows)
End If
ElseIf strCheck_B <> "Pos" And strCheck_C = "Pos" Then
If InStr(strDataShortText, strKeyword_A) > 0 And InStr(strDataShortText, strKeyword_C) > 0 Then
Data.Range("S" & intLoopDataShortTextRows) = wsKeywords.Range("E" & intLoopKeywordsRows)
End If
ElseIf strCheck_B <> "Pos" And strCheck_C <> "Pos" Then
If InStr(strDataShortText, strKeyword_A) > 0 Then
Data.Range("S" & intLoopDataShortTextRows) = wsKeywords.Range("E" & intLoopKeywordsRows)
End If
End If
End If
'########################################################################################
End If
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Next intLoopDataShortTextRows
Next intLoopKeywordsRows
My question is whether there is a faster / more efficient way of doing this?
EDIT: DATA DESCRIPTION
The data column contains descriptions, such as "Green Garden Hose".
The Keywords sheet contains three columns for entering keywords. These are singular words such as "HOSE", "GREEN", and "GARDEN". To match a keyword to a Value (which in this case is numeric), it must match all keywords in the three columns, but the columns do not need to be filled. If there is only 1 keyword, only that keyword will be looked for. If there is two keywords in two of the columns, the description must contain both etc.
Placing a "-" before a keyword means that the keyword must now be excluded for the value to be assigned. E.G. say the description is "Blue Panel", and the first two keyword columns contains "PANEL" and "-BLUE", the value would not be assigned as BLUE must be excluded from the description.