i have the following problem:
I have several values like ABD and then at the end i have (0-9; A-Z) defining the range.
So if you write it out it's ABD0; ABD1;... ABDY; ABDZ.
I have two table structures:
How can i write out the ranges for both table structures (view them as separate) with formula or VBA code?
SO that i have all the ranges written out like ABD0; ABD1;... ABDY; ABDZ.
Thanks in advance.
Updated Picture:
Next Picture:
Update 3:
Please, try the next VBA code:
Sub WriteRangeSeries()
Dim x As String, strPref As String, strCond As String, arrCond, strRow As String, strCol As String
Dim arrRow, arrCol, arrNumb() As String, arrLetters() As String, arrRng() As String, bool0 As Boolean
x = "ABD(0-11;A-Z)"
strPref = left(x, InStr(x, "(") - 1) 'extract prefix before "(" - ABD, in this case
strCond = Mid(x, Len(strPref) + 2)
strCond = left(strCond, Len(strCond) - 1) 'extract conditions to be processed (numbers and letters ranges)
arrCond = Split(Replace(strCond, " ", ""), ";") 'just for the case of spaces existing as: 0 - 11;A-Z, 0-11; A-Z, 0-11;A- Z
arrRow = Split(arrCond(0), "-"): If arrRow(0) = "0" Then arrRow(0) = "1": bool0 = True 'replace 0 with 1 in case of its existing as the first digit
strRow = Join(arrRow, ":") 'create the string to be evaluated as transposed rows
arrCol = Split(arrCond(1), "-"): arrCol(0) = Asc(arrCol(0)): arrCol(1) = Asc(arrCol(1))
strCol = Join(arrCol, ":")
arrNumb = Split(strPref & Join(Evaluate("TRANSPOSE(ROW(" & strRow & ")-" & IIf(bool0, 1, 0) & ")"), "|" & strPref), "|")
Debug.Print Join(arrNumb, "|") 'just to visually see the joined created array
arrLetters = Split(strPref & Join(Evaluate("CHAR(TRANSPOSE(ROW(" & strCol & ")))"), "|" & strPref), "|")
Debug.Print Join(arrLetters, "|") 'just to visually see the joined created array
arrRng = Split(Join(arrNumb, "|") & "|" & Join(arrLetters, "|"), "|")
'drop the built array content, starting from "A2". You can choose this cell as you need/wont:
Range("A2").Resize(1, UBound(arrRng) + 1).Value2 = arrRng
End Sub
Dis is the didactic approach, a little easier to be understood...
You can use it as a function:
Function createRangeArr(x As String) As String()
Dim strPref As String, strCond As String, arrCond, strRow As String, strCol As String
Dim arrRow, arrCol, arrNumb() As String, arrLetters() As String, arrRng() As String, bool0 As Boolean
strPref = left(x, InStr(x, "(") - 1) 'extract prefix before "(" - ABD, in this case
strCond = Mid(x, Len(strPref) + 2)
strCond = left(strCond, Len(strCond) - 1) 'extract conditions to be processed (numbers and letters ranges)
arrCond = Split(Replace(strCond, " ", ""), ";") 'just for the case of spaces existing as: 0 - 11;A-Z, 0-11; A-Z, 0-11;A- Z
arrRow = Split(arrCond(0), "-"): If arrRow(0) = "0" Then arrRow(0) = "1": bool0 = True 'replace 0 with 1 in case of its existing as the first digit
strRow = Join(arrRow, ":") 'create the string to be evaluated as transposed rows
arrCol = Split(arrCond(1), "-"): arrCol(0) = Asc(arrCol(0)): arrCol(1) = Asc(arrCol(1)) 'replace the letters with their ASCII value
strCol = Join(arrCol, ":") 'create the string to be evaluated
'create the array involving numbers:
arrNumb = Split(strPref & Join(Evaluate("TRANSPOSE(ROW(" & strRow & ")-" & IIf(bool0, 1, 0) & ")"), "|" & strPref), "|")
'create the array involving letters:
arrLetters = Split(strPref & Join(Evaluate("CHAR(TRANSPOSE(ROW(" & strCol & ")))"), "|" & strPref), "|")
createRangeArr = Split(Join(arrNumb, "|") & "|" & Join(arrLetters, "|"), "|") 'make the array by splitting the above joined arrays
End Function
And can be used in the next way:
Sub testCreateRange()
Dim x As String, arrRng() As String, rngFirstCell As Range
x = "ABD(0-11;A-Z)"
Set rngFirstCell = Range("A2")
arrRng = createRangeArr(x)
rngFirstCell.Resize(1, UBound(arrRng) + 1).Value2 = arrRng
End Sub
Or using it as UDF, placing the next formula in a cell:
=createRangeArr(A1)
Of course, in A1 (or somewhere else) must be the string to be evaluated (ABD(0-11;A-Z))...
Edited:
In order to build the string to be evaluated from two cells value, you can simple use (as UDF) formula:
=createRangeArr(A1&A2)
Of course, A1 and A2 will keep partial strings to build the necesssary one...
And in case of calling the function from VBA, you can use:
arrRng = createRangeArr(Range("A1").value & Range("A2").value)
Try this:
=LET(C,A2,D,TEXTSPLIT(SUBSTITUTE(SUBSTITUTE(TEXTAFTER(C,"("),")",""),"-",";"),";"),T,TEXTBEFORE(C,"("),VSTACK(T&CHAR(ROW(INDIRECT(CODE(INDEX(D,1))&":"&CODE(INDEX(D,2))))),IFERROR(T&CHAR(ROW(INDIRECT(CODE(INDEX(D,3))&":"&CODE(INDEX(D,4))))),"")))
Change A2 with your cell reference
edit
modified to include more than 1 digit and more than 1 alphabetic char
=LET(C,A2,D,TEXTSPLIT(SUBSTITUTE(SUBSTITUTE(TEXTAFTER(C,"("),")",""),"-",";"),";"),T,TEXTBEFORE(C,"("),VSTACK(T&SEQUENCE(INDEX(D,2)-INDEX(D,1)+1,1,INDEX(D,1)),T&IFERROR(SUBSTITUTE(ADDRESS(1,SEQUENCE(COLUMN(INDIRECT(INDEX(D,4)&"1"))-COLUMN(INDIRECT(INDEX(D,3)&"1"))+1,1,COLUMN(INDIRECT(INDEX(D,3)&"1"))),4),"1",""),"")))
I've seen your new request and this is to expand horizontally from two cells
=LET(C,SUBSTITUTE(A2&B2;" ";""),D,TEXTSPLIT(SUBSTITUTE(SUBSTITUTE(TEXTAFTER(C,"("),")",""),"-",";"),";"),T,TEXTBEFORE(C,"("),TRANSPOSE(VSTACK(T&SEQUENCE(INDEX(D,2)-INDEX(D,1)+1,1,INDEX(D,1)),T&IFERROR(SUBSTITUTE(ADDRESS(1,SEQUENCE(COLUMN(INDIRECT(INDEX(D,4)&"1"))-COLUMN(INDIRECT(INDEX(D,3)&"1"))+1,1,COLUMN(INDIRECT(INDEX(D,3)&"1"))),4),"1",""),""))))
Disposing of Excel/MS 365 and the new TextSplit() function you might profit from
the following blockwise calculation of array results.
Note that I assumed the entire code inputs in column A only - it would be relatively easy, however to change the procedure also for the case of code inputs in two separate columns A:B as mentioned by Dani as further possible input option.
Sub TxtSplit()
Const colOffset As Long = 3 ' column offset for target
Const colCount As Long = 36 ' 10 nums + 26 chars = 36
With Sheet1 ' << change to wanted Project's sheet Code(Name)
'1. define data range containing codes ' e.g. "ABD(0-3;M-N)", etc.
Dim lastrow As Long
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
Dim rng As Range
Set rng = .Range("A2:A" & lastrow) ' << define start row as needed
'2. get codes
Dim codes: codes = rng.Value ' variant 1-based 2-dim datafield array
'3. clear target (e.g. 3 columns to the right)
rng.Offset(, colOffset).Resize(, colCount) = vbNullString
'4. calculate results and write them to range offset
Dim i As Long
For i = 1 To UBound(codes) ' << Loop
'a) get definitions elements
Dim defs ' 1 2 3 4 5
defs = getDefs(codes(i, 1)) ' ABD|0|3|M|N|
'b) get array elements with numeric and character suffixes
Dim num: num = getNum(defs)
Dim char: char = getChars(defs)
'c) write results to target (e.g. 3 columns to the right)
With rng.Cells(1, 1).Offset(i - 1, colOffset)
.Resize(1, UBound(num)) = num
.Offset(, UBound(num)).Resize(1, UBound(char)) = char
End With
Next i
End With
End Sub
Help functions
getNums()... calculating the items with numeric suffixes using a Sequence() evaluation
getChars().. calculating the items with character suffixes using a Sequence() evaluation
getDefs()... tokenizing the code inputs via a TextSplit() evaluation (based on an array of delimiters)
col()....... getting column numbers out of character inputs
Function getNum(x, Optional ByVal myFormula As String = "")
myFormula = _
"""" & x(1) & """ &" & _
"Sequence(" & Join(Array(1, x(3) - x(2) + 1, x(2)), ",") & ")"
getNum = Evaluate(myFormula)
End Function
Function getChars(x, Optional ByVal myFormula As String = "")
myFormula = _
"""" & x(1) & """ & " & _
"Char(" & "Sequence(" & Join(Array(1, x(5) - x(4) + 1, x(4)), ",") & ")" & "+64)"
getChars = Evaluate(myFormula)
End Function
Function getDefs(ByVal code As String, Optional ByVal myFormula As String = "")
'Purp: tokenize code string, e.g. ABD(0-3;M-N) ~~> ABD|0|3|M|N|
'a) split code into tokens (via array of delimiters)
myFormula = "=TEXTSplit(""" & code & """,{""("","";"",""-"","")""})"
Dim tmp: tmp = Evaluate(myFormula) ' e.g. ABD|0|3|M|N|
'b) change column characters into numeric values
Dim i As Long
For i = 4 To 5: tmp(i) = col(tmp(i)): Next ' col chars to nums
'c) return definitions
getDefs = tmp
End Function
Function col(ByVal colChar As String) As Long
'Purp: change column character to number
col = Range(colChar & 1).Column
End Function
My spreadsheet currently has a column C with rows of data that have this structure below:
123 - abc - xyz
I want my VBA code to remove all the data before the first - including the - so that the column C would look like this:
abc - xyz
My current code is removing both "-"
Sub TrimCell()
Dim i As String
Dim k As String
i = "-"
k = ""
Columns("C").Replace what:=i, replacement:=k, lookat:=xlPart,
MatchCase:=False
End Sub
The Excel function I have for this is =REPLACE(C1,1,FIND("-",C1),""). This works but I want something in VBA.
This will work on column C:
Sub my_sub()
Dim c As Range
For Each c In Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("C:C"))
c = Trim(Mid(c, InStr(c, "-") + 1))
Next
End Sub
You want to find the location of the first "-"
location = instr(1, cells(iRow,3), "-", vbTextCompare)
Taking advantage of fact that instr only returns the first entry...
Then trim the cell to the right using that location
if location > 0 then
'Found a "-" within this cell
cells(iRow,3) = right(cells(iRow,3), len(cells(iRow,3)-location)
end if
iRows is obviously just my iterator over the rows in your data. Define it whatever way you want.
You could dot it in one go using Evaluate.
With Range("C1", Range("C" & Rows.Count).End(xlUp))
.Value = Evaluate("MID(" & .Address & ", FIND(""-"", " & .Address & ")+1, LEN(" & .Address & "))")
End With
Please, try the next function:
Function replaceFirstGroup(x As String) As String
Dim arr
arr = Split(x, " - ")
arr(0) = "###$"
replaceFirstGroup = Join(Filter(arr, "###$", False), " - ")
End Function
It can be called/tested in this way:
Sub testReplaceFirstGroup()
Dim x As String
x = "123 - abc - xyz"
MsgBox replaceFirstGroup(x)
End Sub
In order to process C:C column, using the above function, please use the next code. It should be extremely fast using an array, working in memory and dropping the processing result at once:
Sub ProcessCCColumn()
Dim sh As Worksheet, lastR As Long, arr, i As Long
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.rows.count).End(xlUp).row
arr = sh.Range("C2:C" & lastR).value
For i = 1 To UBound(arr)
arr(i, 1) = replaceFirstGroup(CStr(arr(i, 1)))
Next i
sh.Range("C2").Resize(UBound(arr), 1).value = arr
End Sub
I am trying to trim a string down using MID such that everything after the second to last instance of / is removed.
mom/dad/brother/sister/me/ to mom/dad/brother/sister/
thor/ironman/thanos/ to thor/ironman/
I am trying to use combination of Mid, Left and InStrRev but am likely over thinking this. What I have is below and nothing is happening....
For i = 2 to LR
dq.Range("U" & i) = Mid(dq.Range("U" & i), 1, InStrRev(Mid(dq.Range("U" & i), 1, Len(dq.Range("U" & i) - 1)), "/", -1, vbTextCompare))
Next i
I'm guessing the issue is with InStrRev
Use Split
For i = 2 To LR
Dim spltStr() As String
'Split the string on the "\"
spltStr = Split(dq.Range("U" & i), "/")
'Remove the last two
ReDim Preserve spltStr(UBound(spltStr) - 2)
'Join the array with "/" as the delimiter and add the extra on the back
dq.Range("U" & i).Value = Join(spltStr, "/") & "/"
Next i
Before:
After:
#Craners solution also works and is much faster
Issue with my approach:
Len(Range - 1) is invalid. This should be Len(Range) - 1
Removed vbTextCompare
The below returns correct results to trim a string up-until & inclusive of the 2nd to last instance of a character.
Mid(dq.Range("U" & i), 1, InStrRev(Mid(dq.Range("U" & i), 1, Len(dq.Range("U" & i)) - 1), "/", -1))
Here's a nice little function that does the trick
Option Explicit
Sub TestStrip()
Debug.Print Strip("mom/dad/brother/sister/me/", "/", 2)
Debug.Print Strip("thor/ironman/thanos/", "/", 2)
End Sub
Function Strip(ByVal Source As String, ByVal Seperator As String, ByVal StripCount As Long) As String
Dim myArray As Variant
Dim mySeperatorCount As Long
mySeperatorCount = Len(Source) - Len(Replace(Source, Seperator, vbNullString))
myArray = Split(Source, Seperator, mySeperatorCount - StripCount + 2)
Strip = Left(Source, Len(Source) - Len(myArray(UBound(myArray))))
End Function
I'm trying to compared 2 different excel files that contain same fields sometimes.
When I find it (by watch view) the vba say they are different...
Dim ctrl As Integer
Sub btnCheck_Click()
Dim lot As Workbook, pr As Workbook, this As Workbook
Dim a As Variant, b As Variant
Dim i As Integer, j As Integer
Dim passed As Boolean
Set this = Application.ThisWorkbook
this.Worksheets(1).Range("C5:J1000").ClearContents
Application.ScreenUpdating = False
a = ThisWorkbook.Path & "\" & "A.xlsx"
Set lot = Application.Workbooks.Open(a, False, False)
b = ThisWorkbook.Path & "\" & "B.xls"
Set pr = Application.Workbooks.Open(b, False, False)
i = 2
x = 2
lin = 2
Do Until lot.Worksheets(1).Range("A" & i).Value = ""
passed = False
j = 2
Do Until pr.Worksheets(1).Range("A" & j).Value = ""
If lot.Worksheets(1).Range("B" & i).Value = pr.Worksheets(1).Range("C" & j).Value Then
passed = True
this.Worksheets(1).Range("D" & x).Value = "ok"
x = x + 2
End If
j = j + 1
Loop
i = i + 1
Loop
lot.Close True
Set lot = Nothing
pr.Close True
Set pr = Nothing
Application.ScreenUpdating = True
End Sub
Function CleanStr(ByVal str As String)
CleanStr = Replace(str, Chr$(32), "")
End Function
The files A and B are linked at the comments bellow.
A and B are not the same. One ends in a space (ASCII 32) while the other ends in a non-breaking space (ASCII 160). Invisible is invisible to our eyes, but to a computer, ASCII(32)<>ASCII(160)
You can verify this by adding this function to your macro:
Function strings2ascii(ByVal str1 As String, str2 As String)
Dim x As Integer
Dim intStrLen As Integer
Dim strResult As String
If Len(str1) > Len(str2) Then
intStrLen = Len(str1)
Else
intStrLen = Len(str2)
End If
For x = 1 To Len(str1)
strResult = strResult & Asc(Mid(str1, x, 1)) & ":" & Asc(Mid(str2, x, 1)) & vbCrLf
Next
MsgBox strResult
End Function
Now call this function in your loop:
Do Until pr.Worksheets(1).Range("A" & j).Value = ""
strings2ascii lot.Worksheets(1).Range("B" & i).Value, pr.Worksheets(1).Range("C" & j).Value
If lot.Worksheets(1).Range("B" & i).Value = pr.Worksheets(1).Range("C" & j).Value Then
You will immediately see that they never match because they are not the same. Here is a similar SO post regarding ASCII 160 errors: Trouble replacing Chr(160) with VBA in excel
Not sure if this will answer the question but that can't stand in a comment :)
I would say that some cells contains invisible chars that arent spaces.
Here's a recursive function that remove them from a string :
Function CleanString(StrIn As String) As String
' "Cleans" a string by removing embedded control (non-printable)
' characters, including carriage returns and linefeeds.
' Does not remove special characters like symbols, international
' characters, etc. This function runs recursively, each call
' removing one embedded character
Dim iCh As Integer
CleanString = StrIn
For iCh = 1 To Len(StrIn)
If Asc(Mid(StrIn, iCh, 1)) < 32 Then
'remove special character
CleanString = Left(StrIn, iCh - 1) & CleanString(Mid(StrIn, iCh + 1))
Exit Function
End If
Next iCh
End Function
Give it a try like this :
Do Until b.Worksheets(1).Range("A" & j).Value = ""
sa = CleanString(a.Worksheets(1).Range("B" & i).Value)
sb = CleanString(b.Worksheets(1).Range("C" & j).Value)
oa = CleanString(a.Worksheets(1).Range("E" & i).Value)
ob = CleanString(b.Worksheets(1).Range("F" & j).Value)
If StrComp(sa, sb) = 0 And StrComp(oa, ob) = 0 Then
Passed = True
This is what I am trying to do:
If J contains the word Defendant
And
If F contains the word Foreclosure
Then
If G contains " V ESTATE OF "
Then keep everything to the right of "OF"
Else If G contains " VS "
Then keep everything to the right of " VS "
Else If G contains " V " (notice the spaces before and after V)
Then keep everything to the right of " V "
If K contains " " (two consecutive spaces)
Then Keep it
Or
If K contains "UNKNOWN SPOUSE OF"
Then remove the very last character of cell, which will be a comma
And if the cell begins with an underscore
Then remove it
Then Keep it
Assign the result of G to the corresponding N cell
Assign the result of K to the corresponding O cell
This is what I did:
Sub Inspect()
Dim RENums As Object
Dim RENums2 As Object
Dim LValue As String
Dim LValue2 As String
Set RENums = CreateObject("VBScript.RegExp")
Set RENums2 = CreateObject("VBScript.RegExp")
RENums.Pattern = "DEFENDANT"
RENums2.Pattern = "FORECLOSURE"
Dim lngLastRow As Long
lngLastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Dim i
For i = 1 To lngLastRow
If RENums2.test(Range("F" & i).Value) Then
If RENums.test(Range("J" & i).Value) Then
pos = InStr(Range("G" & i), " V ")
pos2 = InStr(Range("G" & i), " VS ")
pos3 = InStr(Range("G" & i), " V ESTATE OF ")
dbspace = InStr(Range("K" & i), " ")
If pos3 <> 0 Then
LValue2 = Right(Range("G" & i), Len(Range("G" & i)) - pos * 2)
ElseIf pos <> 0 Then
LValue2 = Right(Range("G" & i), Len(Range("G" & i)) - pos - 2)
ElseIf pos2 <> 0 Then
LValue2 = Right(Range("G" & i), Len(Range("G" & i)) - pos - 2)
End If
If dbspace <> 0 Then
LValue = Range("K" & i)
End If
schr = Right(LValue, 1)
If schr = "_" Then
With WorksheetFunction
Range("N" & i).Value = Trim(.Substitute(LValue, "_", ""))
End With
Else
Range("N" & i).Value = Trim(LValue)
End If
Range("O" & i).Value = Trim(LValue2)
End If
End If
Next i
End Sub
With the above macro, the correct value is never pasted into N in some cases. Rather a value from another cell in K is pasted to the wrong cell in N.
I attached an example of excel spreadsheet on the below link to which I never received a response:
http://www.excelforum.com/excel-programming/775695-wrong-data-copied-into-new-cell-from-macro.html
Thanks for response.
Your LValue and LValue2 variables are being populated conditionally (ie, not each time through the loop), but your final block is executed EVERY TIME, so it stands to reason that some times through the loop, you are using an old value of LValue or LValue2 (or both).
You need to clear them out at the beginning of the loop, or else have an ELSE clause in both your LValue and LValue2 IF blocks that takes care of that scenario.
Edit based on your comment: I prefer using MID() to RIGHT() in this scenario, makes it much easier to get the math right, since we're counting from the left (which is the value that InStr() returns):
cellText = Range("K" & i).Value
LValue = Mid(cellText, Unknown + 18, 100)
A few additional notes:
You use it so many times, put the tested value into a variable like I did above. It might even be marginally faster that way instead of going back to the worksheet each time.
I prefer to use Cells(11, i).Value to Range("K" & i).Value. Works the same, but much easier to use with variable row or column numbers.
It usually works the way you've done it, but make sure to use the correct property of the range object (Range().Value or Range().Formula or whatever) instead of just relying on the "default property" to always be correct.
When checking for the underscore, you are testing if the last character is an underscore. Your question states that you want to test if the value begins with an underscore.
schr = Right(LValue, 1)
If schr = "_" Then
Try
schr = Left(LValue, 1)
If schr = "_" Then