How do I convert the alpha part of an excel address "$C$2" to 3 and 2 so that I could re-use it in a cell object.
If it is "$E$4", then I need two separate values like 5 (for the letter E) and 4, so that I could reference that using the object - Cells(4,5)
Basically, I am trying to un-merge cells using this code below and that is where the need to get the numeral of the excel cell came about.
Sub UnMerge()
Dim i As Integer
Dim fromRange() As String
Dim toRange() As String
Dim temp() As String
ActiveSheet.UsedRange.MergeCells = False
fromRange() = Split(ActiveCell.Address, "$")
temp() = Split(Selection.Address, ":")
toRange() = Split(temp(1), "$")
For i = fromRange(2) To toRange(2)
If Cells(i, Range(temp(0)).Column) = "" Then
Cells(i, Range(temp(0)).Column) = Cells(i - 1, Range(temp(0)).Column).Value
End If
Next i
End Sub
Debug.Print Range("$E$4").Row & ", " & Range("A1").Column
changing and spliting strings to get to numbers is slow. Just use the selection.rows and selection.column:
Sub UnMerge()
Selection.MergeCells = False
With ActiveSheet
Dim i As Long
For i = Selection.Row To Selection.Rows.Count + Selection.Row - 1
If .Cells(i, Selection.Column) = "" Then
.Cells(i, Selection.Column) = .Cells(i - 1, Selection.Column).Value
End If
Next i
End With
End Sub
Related
I have written a simple VBA script (code below) that should inspect every cell in a certain column. Here I want to do some string manipulation ( i wante to search for "." in the string and then take the right side, but because I could not get it to work I always take the 4 digit as a start). I then copy the manipulated string into another cell and later back. The code works, but for some reason, it takes ages to run on only 35 cells!
I´m still a kook on VBA and wanted to get input what could be the reason for it and what I could improve to get a faster runtime. Is it because I take all strings froms 4 up to 50 ?
Sub EditStatus()
Application.DisplayAlerts = False
ActiveSheet.Name = "Backend"
myNum = Application.InputBox("Please enter the row number until which you would like to update the status column (only for new entries)")
For i = 2 To myNum
Cells(i, 20).Value = Mid(Cells(i, 10), 4, 50)
Cells(i, 10).Value = Cells(i, 20).Value
Next i
Range("T1:T200").Clear
Application.DisplayAlerts = True
End Sub
Thanks
No need for a loop. You can enter the formula in the entire range in 1 go and then convert them to values before putting the values back in Col J
Replace
For i = 2 To myNum
Cells(i, 20).Value = Mid(Cells(i, 10), 4, 50)
Cells(i, 10).Value = Cells(i, 20).Value
Next i
With
With Range("T2:T" & myNum)
.Formula = "=MID(J2, 4, 50)"
.Value = .Value
Range("J2:J" & myNum).Value = .Value
End With
Alternatively, you can directly perform the same action in Col J without the helper column T. For example you can do all that in 1 line as explained HERE as well
Simply replace
For i = 2 To myNum
Cells(i, 20).Value = Mid(Cells(i, 10), 4, 50)
Cells(i, 10).Value = Cells(i, 20).Value
Next i
Range("T1:T200").Clear
with
Range("J2:J" & myNum).Value = Evaluate("Index(MID(" & "J2:J" & myNum & ", 4, 50),)")
Replace Values In-Place
Adjust the values in the constants section.
This solution overwrites the data and doesn't use a helper column, but you can test it with one indicated near the end of the code.
Solve the renaming (Backend) part as needed.
The Code
Option Explicit
Sub EditStatus()
' Define constants.
Const sPrompt As String = "Please enter the row number until which you " _
& "would like to update the status column (only for new entries)"
Const sTitle As String = "Enter Number"
Const wsName As String = "Backend"
Const First As Long = 2
Const cCol As Long = 10 ' J
Const Delim As String = "."
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Require input.
Dim Last As Variant
Last = Application.InputBox( _
Prompt:=sPrompt, Title:=sTitle, Default:=First, Type:=1)
' Validate input.
If VarType(Last) = vbBoolean Then
MsgBox "You cancelled."
Exit Sub
End If
If Last < First Then
MsgBox "Enter a number greater than " & First - 1 & "."
Exit Sub
End If
If Int(Last) <> Last Then
MsgBox "Enter a WHOLE number greater than " & First - 1 & "."
Exit Sub
End If
' Define column range.
Dim rg As Range
Set rg = wb.Worksheets(wsName).Cells(First, cCol).Resize(Last - First + 1)
' Write values from column range to array.
Dim Data As Variant
If rg.Rows.Count > 1 Then
Data = rg.Value
Else
ReDim Data(1 To 1, 1 To 1): Data = rg.Value
End If
' Declare additional variables
Dim cValue As Variant ' Current Value
Dim i As Long ' Current Row (Array Row Counter)
Dim fPos As Long ' Current Delimiter Position
' Replace strings containing the delimiter, with the sub string
' to the right of it.
For i = 1 To UBound(Data)
cValue = Data(i, 1)
If Not IsError(cValue) Then
fPos = InStr(1, cValue, Delim)
If fPos > 0 Then
Data(i, 1) = Right(cValue, Len(cValue) - fPos)
End If
End If
Next i
' Maybe rather test with the following (writes to column 20 ("T")).
'rg.Offset(, 10).Value = Data
' Write values from array to column range.
rg.Value = Data
End Sub
I have searched many posts, forums, tutorials, I tried combine some of them, but nothing really worked for me. Now I write some code, that by logic I learn from other programming languages it should work, but I'm missing few steps.
Let's assume I have string like this
Test User <TUser#my-domain.pl>; Test User2 <TUser2#my-domain.pl>; Test User3 <TUser3#my-domain.pl>; Test User4 <TUser4#my-domain.pl>;
I paste that into cell, let's say A1. My goal is to be left with Test User or TUser for each smaller string.
I can achive my goal by doing so:
Click Text as columns -> Delimited -> Other ;, now each string is in separate column
Copy whole A row and paste it with transpose(rotate), so each string is in separate row
Now easiest way is to use Text as columns, by < delimiter. So all I'm left with is Name Surname in one cell and rest in other
I want to achive that, by clicking on the button of course.
My code so far:
Sub GetName()
Dim WordList As String
Dim ArrayOfWords
Dim i, i2 As Integer
'Define my word list, based on cell
WordList = Cells(1, 1)
'Use SPLIT function to convert the string to an array
ArrayOfWords = Split(WordList, "<")
'Iterate through array, and put each string into new row cell
i = 2
i2 = 1
Do While (ThereIsNoMoreText)'That I cannot figure out
Cells(2, i).Value = ArrayOfWords(i2)
i = i + 1
i2 = i2 + 1
Loop
End Sub
Thanks for you help in advance and I hope I make it clear :)
Fun little alternative:
Sub Test()
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "(?:<.*?>)"
arr = Split(.Replace([A1], ""), ";")
End With
With Cells(1, 2).Resize(UBound(arr))
.Value = Application.Transpose(arr)
.Value = Application.Trim(.Value)
End With
End Sub
Obviously, be sure to create an explicit sheet reference for Cells.
You need to split by semicolon first.
Break the following apart to get the strings you need:
userlist = Split(Cells(1, 1).Value, ";")
i = 1
For Each user In userlist
i = i + 1
splituser = Split(user, "<")
Cells(i, 1) = splituser(0)
Cells(i, 2) = Mid(splituser(1), 1, Len(splituser(1)) - 1)
Next
In addition to the methods shown in others answers (in particular the very impressive one by #JvdV) you could also try this.
This method does not use For…Next
Sub Users_Email_Split()
Dim aData As Variant
With ThisWorkbook.Worksheets("TEST")
aData = .Cells(1).Value
aData = Left(aData, -2 + Len(aData))
aData = Replace(aData, " <", """,""")
aData = Replace(aData, ">; ", """;""")
aData = "{""" & aData & """}"
aData = Application.Evaluate(aData)
.Cells(2, 2).Resize(UBound(aData), UBound(aData, 2)).Value = aData
End With
End Sub
EDIT
If the string is expected to exceed the 255 characters limit for the Evaluate Function then you could use this method (up to a max of 2086 characters).
This method a creates an User Defined Name with the array string as a formula, then applies the Name as a FormulaArray, and finally sets the value of the range.
Sub Users_Email_Split_Plus255()
Dim aData As Variant
Dim lR As Long, lC As Long
With ThisWorkbook.Worksheets("TEST")
aData = .Cells(11, 1).Value
aData = Left(aData, -2 + Len(aData))
aData = Replace(aData, " <", """,""")
aData = Replace(aData, ">; ", """;""")
aData = "={""" & aData & """}"
lR = 1 + UBound(Split(aData, ";"))
lC = 1 + UBound(Split(Split(aData, ";")(0), ","))
With .Cells(12, 2).Resize(lR, lC)
.Worksheet.Names.Add Name:="_FmlX", RefersTo:=aData
.FormulaArray = "=_FmlX"
.Value = .Value
End With: End With
End Sub
You have to modify the construct a bit
Dim i As Long
Dim FirstPart As String, SecondPart As String
Dim ArrayOfWords
ArrayOfWords = Split(Cells(1, 1).Value, ";")
For i = LBound(ArrayOfWords) To UBound(ArrayOfWords)
If InStr(1, ArrayOfWords(i), "<") > 0 Then
FirstPart = Left(ArrayOfWords(i), InStr(1, ArrayOfWords(i), "<") - 1)
SecondPart = Mid(ArrayOfWords(i), Len(FirstPart) + 1, Len(ArrayOfWords(i)))
Debug.Print FirstPart & "--" & SecondPart
End If
Next i
The below VBA code sets a range of cells as commentArray, removes any blanks from the array and creates a new, blank free array, called commentResults. I then want to declare the array.
There is a possibility, depending on my source data, that the array could then still be empty so the below doesn't work to declare
thisws.Cells(i, 19).Resize(columnsize:=UBound(commentResults) - LBound(commentResults) + 1).Value = commentResults
So I thought I would add a check (the if statement after the debug.print), that only declared the array if array(0) wasn't empty but I continuously get an error 9 which I can't resolve.
Dim commentArray(4) As Variant
commentArray(0) = Cells(24, 4).Value
commentArray(1) = Cells(25, 3).Value
commentArray(2) = Cells(26, 3).Value
commentArray(3) = Cells(27, 3).Value
'a and b as array loops
Dim a As Long, b As Long
Dim commentResults() As Variant
'loops through the array to remove blanks - rewrites array without blanks into commentArray
For a = LBound(commentArray) To UBound(commentArray)
If commentArray(a) <> vbNullString Then
ReDim Preserve commentResults(b)
commentResults(b) = commentArray(a)
b = b + 1
End If
Next a
Debug.Print b
If IsError(Application.Match("*", (commentResults), 0)) Then
Else
thisws.Cells(i, 19).Resize(columnsize:=UBound(commentResults) - LBound(commentResults) + 1).Value = commentResults
b = 0
End If
Any thoughts on why this might not work?
I have also tried:
If commentResults(0) <> vbNullString Then
thisws.Cells(i, 27).Resize(columnsize:=UBound(commentResults) - LBound(commentResults) + 1).Value = commentResults
End If
Sub CommentArray()
Dim Comments As Range, c As Range
Set Comments = Union(Cells(24, 4), Range(Cells(25, 3), Cells(27, 3)))
Dim commentResults() As Variant
Dim i As Long
i = 0
For Each cell In Comments
If cell.Value <> "" Then
ReDim Preserve commentResults(i)
commentResults(i) = cell.Value
i = i + 1
End If
Next cell
Dim debugStr As String
For i = LBound(commentResults) To UBound(commentResults)
debugStr = debugStr & commentResults(i) & Chr(10)
Next i
MsgBox debugStr
End Sub
I am trying to compare values in two lists. I want my code to compare a value in the first list and check all the entries in the second list. If there is a match then the code will print true next to the value in the first list and if not it will print false.
The problem I am having is that my code only compares values that are in the same row.
The code runs and I have tried it on a two smaller lists to make sure the data types are to same and there aren't any extra spaces or commas in the lists that would lead to a "False" output. I have also tried changing the order of the for and if statements but this doesn't work either.
Sub findvalues()
For i = 2 To 16
For j = 2 To 16
If Cells(i, 3).Value = Cells(i, 1).Value Then
Cells(i, 4).Value = "TRUE"
ElseIf Cells(i, 3).Value = Cells(j + 1, 1).Value Then
Cells(i, 4).Value = "TRUE"
Else
Cells(i, 4).Value = "FALSE"
End If
Next j
Next i
End Sub
Here are the two lists I am testing the code on
Slight mods to your code based on the data you provided in columns 1 & 3. As always, things could be improved but this should get you going ...
Sub findvalues()
Dim i As Long, j As Long, bResult As Boolean
For i = 2 To 16
strValueToLookFor = Cells(i, 1)
For j = 2 To 16
bResult = False
If strValueToLookFor = Cells(j, 3).Value Then
bResult = True
Exit For
End If
Next j
Cells(i, 6).Value = bResult
Next i
End Sub
... you may just need to flick the columns over so the first list searches on the second list or vice versa.
I don't see any need for VBA - formulas are the way to go - but to avoid two loops one could do this:
Sub findvalues()
Dim i As Long
For i = 2 To 130
Cells(i, 4).Value = IsNumeric(Application.Match(Cells(i, 1).Value, Range("C2:C130"), 0))
Next i
End Sub
Update: this does not cater for multiple matches.
There are many was to achieve that. one of them is by using IF & COUNTIF
Formula
=IF(COUNTIF($E$2:$E$6,A2)>0,"TRUE","FALSE")
Results:
VBA CODE
Option Explicit
Sub findvalues()
Dim i As Long
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1") 'Change if needed
Set rng = .Range("A2:A130") 'set rng to includes values from column A, rows 2:130
For i = 2 To 130 'Loop from row 2 to 130
'Check if the values in column C includes in the rng
If Application.WorksheetFunction.CountIf(rng, .Range("C" & i).Value) > 0 Then
.Range("D" & i).Value = "TRUE"
Else
.Range("D" & i).Value = "FALSE"
End If
Next i
End With
End Sub
VBA code to reconcile two lists.
Sub Reconciliation()
Dim endRow As Long
Dim ICount As Long
Dim Match1() As Variant
Dim Match2() As Variant
Dim ws As Worksheet
Set ws = Worksheets("Recon")
ICount = 0
endRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
endRow1 = ws.Cells(ws.Rows.Count, 11).End(xlUp).Row
Match1 = Sheet1.Range("b2:b" & endRow)
Match2 = Sheet1.Range("K2:K" & endRow1)
For i = LBound(Match1) To UBound(Match1)
For j = LBound(Match2) To UBound(Match2)
If Match1(i, 1) = Match2(j, 1) Then
ICount = ICount + 1
Sheet1.Range("C" & i + 1).Value = ICount
Sheet1.Range("L" & j + 1).Value = ICount
Else
End If
Next j
Next i
End Sub
Disclaimer- my case is specific, and in my case my code works because I know the pattern.
I was looking for an answer everywhere, and the codes I tried were not quite what I was looking for, this is my solution if you are looking for a set of numbers.
In my case, I was looking for 7 digits, starting with digit 1 in a a column with random strings, some string had the number some others didn't.
The number will appear in these three scenarios "1XXXXXX", "PXXXXXXXX", "PXXXXXXXXX"(this has more digits because there is a slash).
Here are the examples of strings:
9797 P/O1743061 465347 Hermann Schatte Earl Lowe
9797 Po 1743071 404440 Claude Gaudette Jose Luis Lopez
9817 1822037 463889 Jean Caron Mickelly Blaise
My Code
Sub getnum()
'i don't use explicit so i didn't declare everything
Dim stlen As String
Dim i As Integer
Dim arra() As String
Dim arran() As String
Orig.AutoFilterMode = False
Call BeginMacro
LastRow = Orig.Cells(Rows.Count, 1).End(xlUp).Row
Orig.Range("J2:J" & LastRow).Clear
'loop though column
For n = 2 To LastRow
celref = Orig.Cells(n, 4).Value
'split string on white spaces
arra() = Split(celref, " ")
'turn string to multiple strings
For counter = LBound(arra) To UBound(arra)
strin = arra(counter)
'remove white spaces from string
storage = Trim(strin)
lenof = Len(storage)
'if string has 9 characthers, check for conditions
If lenof = 9 Then
'position of first and last charachter
somstr = Mid(storage, 1, 1)
somot = Mid(storage, 9, 1)
If somstr = "P" Or somstr = "p" And IsNumeric(somot) = True Then
'removes Po or PO and keeps only 7 digits
storage = Right(storage, 7)
'stores in column J
Orig.Cells(n, 10).Value = storage
End If
ElseIf lenof = 10 Then
somstr = Mid(storage, 1, 1)
somot = Mid(storage, 10, 1)
'other conditions
If somstr = "P" Or somstr = "p" And IsNumeric(somot) = True Then
'removes Po or PO and keeps only 7 digits
storage = Right(storage, 7)
'stores in column J
Orig.Cells(n, 10).Value = storage
End If
End If
'eliminate comma within
arran() = Split(storage, ",")
If Orig.Cells(n, 10).Value <> storage Then
For counter2 = LBound(arran) To UBound(arran)
strin2 = arran(counter2)
storage2 = Trim(strin2)
'final condition if is 7 digits and starts with 1
If IsNumeric(storage2) = True And Len(storage2) = 7 Then
car = Mid(storage2, 1, 1)
If car = 1 Then
'stores in columns J at specific position
Orig.Cells(n, 10).Value = storage2
End If
Else
If isnumeric(orig.cells(n,10).value) =true and _
len(orig.cells(n,10).value = 7 then
orig.cells(n,10).value = orig.cells(n,10).value
else
Orig.Cells(n, 10).Value = "no po# in D"
End If
Next counter2
End If
Next counter
Next n
Call EndMacro
End Sub
you may try this
Option Explicit
Sub getnum()
Dim position As Variant
Dim cell As Range
With Worksheets("Orig") ' change it to your actual sheet name
With Intersect(.UsedRange, Columns("J"))
.Replace what:="P/O", replacement:="P/O ", lookat:=xlPart
For Each cell In .Cells
position = InStr(cell.Text, " 1")
If position > 0 Then cell.Value = Mid(cell.Value, position + 1, 7)
Next
End With
End With
End Sub
This code paste two formulas one in column G and one in column J). The first formula checks for a "P" in the first character of the cell in column 2 and if there is a "P" it extracts the last 7 characters in the string and puts them in column G. The second formula checks if there is not a "P" and if not extracts the last 7 characters in the string and puts them in column J.
Sub Extract()
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet3")
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("G2:G" & lRow).Formula = "=IF(LEFT(B2)=""P"",(RIGHT(B2,7)),"""")"
ws.Range("J2:J" & lRow).Formula = "=IF(LEFT(B2)<>""P"",(RIGHT(B2, 7)),"""")"
End Sub
You may use the RegEx to extract the number in desired format.
Please give this a try...
Function Get10DigitNumber(ByVal Str As String) As String
Dim RE As Object
Set RE = CreateObject("VBScript.RegExp")
With RE
.Global = False
.Pattern = "1\d{6}"
End With
If RE.test(Str) Then
Get10DigitNumber = RE.Execute(Str)(0)
End If
End Function
Then if you want to use this function on the worksheet itself, assuming your string is in A2, try this...
=Get10DigitNumber(A2)
OR
You may use this function in another sub routine/macro like this...
Debug.Print Get10DigitNumber(<pass your string variable here>)
Edited Function:
Function Get10DigitNumber(ByVal Str As String) As String
Dim RE As Object, Matches As Object
Set RE = CreateObject("VBScript.RegExp")
With RE
.Global = False
.Pattern = "[Pp]?\/?[Oo]?(1\d{6})\b"
End With
If RE.test(Str) Then
Set Matches = RE.Execute(Str)
Get10DigitNumber = Matches(0).SubMatches(0)
End If
End Function
And use if as already described above.
After understanding what you were doing, I think this will work. Any feedback would be appreciated.
Dim cell As Range, LRow As Long
LRow = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
For Each cell In Range("D2:D" & LRow)
If cell.Value Like "*Po *" Then
cell.Offset(0, 6).Value = Split(cell.Value, " ")(2)
Else: cell.Offset(0, 6).Value = Split(cell.Value, " ")(1)
End If
Next cell
For Each cell In Range("J2:J" & LRow)
If Len(cell.Value) > 7 Then
cell.Value = Right(cell.Value, 7)
End If
Next