I'm trying to replace a specific value in my whole Column D.
My Column looks like this:
COLUMN D
TD10.LU89.AX300.MT01
TD10.LU89.BT100.MT01
TD10.LU89.BP130.MP01
Now what I'm trying to do is to replace only the first "." with ".IO."
This is what I have already tried:
Columns("D").Replace _
What:=".", Replacement:=".IO.", LookAt:=xlPart
and obiviously the result is that all the points will be changed:
TD10.IO.LU89.IO.AX300.IO.MT01
Do you guy have a solution to my problem?
Thank you very much in advance.
You could use:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long
Dim str As String
'Change sheet if needed
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row of column D
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
'Loop column D
For i = 1 To LastRow
'Replace the first occurance
str = Replace(.Range("D" & i).Value, ".", ".IO.", , 1)
.Range("D" & i).Value = str
Next i
End With
End Sub
For example
Sub ReplaceDot()
Dim cl As Range
For Each cl In Range("D1:D" & Rows.End(xlUp).Row)
cl.Value = Left(cl.Value, 4) & ".IO." & Right(cl.Value, Len(cl.Value) - 5)
Next cl
End Sub
In case left part is of varying length:
cl.Value = Left(cl.Value, InStr(cl.Value, ".") - 1) & ".IO." & Right(cl.Value, Len(cl.Value) - InStr(cl.Value, "."))
One can make it more universal by adding column and replacement string as params to the sub
Related
I'm not very familiar with VBA, but am in need of a macro that would replace ### to = for columns B, F, and J without affecting rows 1 to 15.
I found the below code as my starting point, but can't seem to adjust it to my situation, or if this would even work for my situation...
this code was replacing everything in B that was not empty to Title starting at B2
Sub replace_text
Dim lrow As Long
Dim rng As Range
lrow = Cells(Rows.Count, "B").End(xlUp).Row 'Detect last data entry row in Column B.
For Each rng In Range("B2:B" & lrow)
If rng <> "" Then
rng = "Title"
End If
Next rng
End Sub
essentially, my goal is to replace every occurrences of text strings that start with ### with = without affecting the remainder of the strings.
everything in column B, F, and J starting at row 16 would start with ### but do not have the same text after the ###.
other columns would also have ### at the start but would need to remain intact
Worksheet.Evaluate: Replace Text
Sub ReplaceText()
Const FIRST_ROW As Long = 16
Const COLUMNS_RANGE As String = "B:B,F:F,J:J"
Const BEGINS_WITH_STRING As String = "###"
Const REPLACE_STRING As String = "="
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range
With ws.UsedRange
Set rg = .Resize(.Rows.Count + .Row - FIRST_ROW).Offset(FIRST_ROW - 1)
End With
Dim arg As Range, aAddress As String, Formula As String
For Each arg In Intersect(rg, ws.Range(COLUMNS_RANGE)).Areas
aAddress = arg.Address
Formula = "IF(LEFT(" & aAddress & "," & Len(BEGINS_WITH_STRING) _
& ")=""" & BEGINS_WITH_STRING & """," & "SUBSTITUTE(" _
& aAddress & ",""" & BEGINS_WITH_STRING & """,""" _
& REPLACE_STRING & """,1)," & aAddress & ")"
'Debug.Print Formula
arg.Value = ws.Evaluate(Formula)
Next arg
MsgBox "Text replaced.", vbInformation
End Sub
I would like to solve the following problem:
In Worksheet1 I have a range in text form from O3 to O4500. If the cells in this range contain certain words, I want an "x" to be put in the range U3:U4500 (in the same row). The words to be tested are in range B4:B15 in another Worksheet (Worksheet2).
I made it work with the following code (solution1), but now I don't want to type the code manually for word1, word2, words3... instead it should be taken from the other range in Worksheet 2 (see my draft below in solution2). I believe the problem are the "* *" which are missing when I use the referral to the other range.
Any help is very much appreciated!
Sub solution1()
Dim i As Long
For i = 3 To 4500
If LCase$(Worksheet1.Range("O" & i).Value) Like "*word1*" Or _
LCase$(Worksheet1.Range("O" & i).Value) Like "*word2*" Or _
LCase$(Worksheet1.Range("O" & i).Value) Like "*word3*" Then
Worksheet1.Range("U" & i).Value = "x"
End If
Next
End Sub
Sub solution2()
Dim i As Long, c As Long
For i = 3 To 4500
For c = 4 To 15
If LCase$(Worksheet1.Range("O" & i).Value) Like LCase$(Worksheet2.Range("B" & c).Value) Then
Worksheet1.Range("U" & i).Value = "x"
End If
Next
Next
End Sub
try something like:
Sub solution2()
Dim i As Long, c As Long
searchstring = LCase$(Worksheets("Worksheet2").Range("B1").Value & "|" & Worksheets("Worksheet2").Range("B2").Value & "|" & Worksheets("Worksheet2").Range("B3").Value)
For i = 2 To 9
If Len(LCase$(Worksheets("Worksheet1").Range("O" & i).Value)) < 1 Then GoTo neexxtt
'line above prevents empty lines to be marked
If InStr(searchstring, LCase$(Worksheets("Worksheet1").Range("O" & i).Value)) <> 0 Then Worksheets("Worksheet1").Range("U" & i).Value = "x"
neexxtt:
Next
End Sub
A VBA Lookup: Using an (Array)Formula For Partial Matches
In Excel, in cell U3, you could use the following array formula:
=IF(COUNT(MATCH("*"&Sheet2!$B$4:$B$15&"*",O3,0))>0,"X","")
and copy it down (adjust the lookup worksheet name (Sheet2)).
The following solution is based on this formula avoiding any loops.
Sub VBALookup()
Const Flag As String = "x"
' Reference the ranges.
Dim srg As Range ' Source
Dim drg As Range ' Destination
Dim lrg As Range ' Lookup
With Worksheet1
Set srg = .Range("O3", .Cells(.Rows.Count, "O").End(xlUp))
Set drg = srg.EntireRow.Columns("U")
End With
With Worksheet2
Set lrg = .Range("B4", .Cells(.Rows.Count, "B").End(xlUp))
End With
' Build the array formula.
Dim ArrayFormula As String
ArrayFormula = "=IF(COUNT(MATCH(""*""&'" & Worksheet2.Name & "'!" _
& lrg.Address & "&""*""," & srg.Cells(1).Address(0, 0) & ",0))>0,""" _
& Flag & ""","""")"
' Write the formulae (values).
With drg
' Write the array formula to the first cell.
.Cells(1).FormulaArray = ArrayFormula
' Autofill to the bottom.
.Cells(1).AutoFill .Cells, xlFillDefault
' Not sure, but instead of the previous 2 lines, in Office 365,
' the following single line should work:
'.Cells.Formula = ArrayFormula
' Convert to values (out-comment if you want to keep the formulae).
.Value = .Value
End With
End Sub
I am hoping someone knows how to vlookup multiple comma separated values in one cell and provide semicolon separated output in the adjacent cell.
I have noticed two other instances of this question on Stack Overflow but, unfortunately, both referred to using formulas (textjoin and vlookup) to solve this issue. Due to another VBA formula I am using, I need the final output to result solely in the text information, not in a formula. Is there any way to do this using VBA? Thanks in advance.
Figured out how to use the vlookup with the split using Ben's suggestion. Only issue is it puts a semicolon at the start of my email string, which is no issue for me but may be for another user.
Sub FINDEM()
Dim ws As Worksheet
Dim cel As Range
Dim LastRow As Long, I As Long
Dim WrdArray() As String
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
For Each cel In .Range("A2:A" & LastRow).Cells 'loop through each cell in Column A
strg = ""
Sal = ""
WrdArray() = Split(cel, ", ")
For I = LBound(WrdArray) To UBound(WrdArray)
Sal = Sal & "; " & Application.WorksheetFunction.VLookup(WrdArray(I), Sheet1.Range("d2:e9"), 2, False)
cel.Offset(0, 1) = Sal
Next I
Next
End With
End Sub
You can do so without iteration, plus you might want to take into consideration removing duplicates. For example:
Sub Test()
Dim lr As Long
Dim arr As Variant, arrA As Variant, arrB As Variant
With ThisWorkbook.Sheets("Sheet1")
'Get last used row and data into memory
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A2:B" & lr).Value
'Join and transpose column A:A and B:B into their own array
With Application
arrA = Split(.Trim(Join(.Transpose(.Index(arr, 0, 1)), ",")), ",")
arrB = Split(.Trim(Replace(Join(.Transpose(.Index(arr, 0, 2)), ";"), Chr(10), "")), ";")
End With
'Write array to sheet
.Range("D2").Resize(UBound(arrA) + 1).Value = Application.Transpose(arrA)
.Range("E2").Resize(UBound(arrB) + 1).Value = Application.Transpose(arrB)
'Remove duplicates from column D:E
.Range("D2:E" & UBound(arrA) + 1).RemoveDuplicates Array(1, 2), xlNo
End With
End Sub
I am trying to create a "If statement" where I check column B if it contains a partial string ("BMC-"). Then write "Bill of Material" in column E.
I already have tried using a formula, but I would like this to written as a macro.
=IF(ISNUMBER(SEARCH("BMC-",B14)), "Bill of Material", "")
Sub Descriptions()
For r = 14 To Cells(Rows.Count, "B").End(xlUp).Row ' From row 1 to
the last row with data
On Error Resume Next
If Cells(r, "B") = "BMC-9" > 0 Then
Cells(r, "E").Value = "Bill of Materials"
End If
Next
End Sub
I am wanting the code to loop until the last row to find all the strings that contains the partial text "BMC-" in column B to write "Bill of Materials" in column E
Just use the formula you already have, no looping required. Also declare your variables. Utilize variables in place of hard-coding constant values so that the code is easier to adjust and maintain. Something like this should work for you:
Sub tgr()
'Declare variables
Dim ws As Worksheet
Dim lHeaderRow As Long
Dim sSearchCol As String
Dim sOutputCol As String
Dim sTextToFind As String
Dim sTextToWrite As String
'Set this to the actual worksheet where you want the formula
Set ws = ActiveWorkbook.ActiveSheet
'Define variables
lHeaderRow = 13 'Header Row. Actual data and results will start on the next row
sSearchCol = "B" 'Column to search for the text
sOutputCol = "E" 'Column to output results
sTextToFind = "BMC-" 'Text to search for
sTextToWrite = "Bill of Material" 'Text that will be output when search text is found
'Use previously defined variables to establish range
With ws.Range(sOutputCol & lHeaderRow + 1 & ":" & sOutputCol & ws.Cells(ws.Rows.Count, sSearchCol).End(xlUp).Row)
If .Row <= lHeaderRow Then Exit Sub 'No data
'Apply your formula to all rows in the range at once
.Formula = "=IF(ISNUMBER(SEARCH(""" & sTextToFind & """," & sSearchCol & .Row & ")), """ & sTextToWrite & """, """")"
'Convert cells to values
.Value = .Value
End With
End Sub
Tim has a solid Like case, though I tend to use InStr():
Sub Descriptions()
For r = 14 To Cells(Rows.Count, "B").End(xlUp).Row
'On Error Resume Next 'get rid of that... find error and fix/build logic, don't ignore it
If Instr(Cells(r, "B").Value, "BMC-9") Then
Cells(r, "E").Value = "Bill of Materials"
End If
Next
End Sub
You can try this approach using split() function:
Sub NewCode()
For r = 14 To Cells(Rows.Count, "B").End(xlUp).Row
Dim myArray As Variant
myArray = Split(Cells(r, "B"), "BMC-")
If UBound(myArray) > 0 Then
Cells(r, "E").Value = "Bill of Material"
End If
Next r
End Sub
I have two columns A and B with numbers as values.
In C1 I want =A1 + B1
In C2 I want =A2 + B2
and so on. I have written the following VBA code - while it works it adds "0" after the end of the last row in range.
Let's assume my last row is A10. It adds "0" in C11 when I run the code.
How do I prevent this?
Sub macro()
Dim R As Long
R = 1
Do
Cells(R, "C").Select
R = R + 1
ActiveCell.Formula = "=sum(" & ActiveCell.Offset(0, -2) & "," &
ActiveCell.Offset(0, -1) & ")"
Loop Until IsEmpty(ActiveCell.Offset(0, -2))
End Sub
Just replace your Until condition to the following string:
Loop Until IsEmpty(ActiveCell.Offset(1, -2))
That will check the right cell for being empty. The rest of your code should remain intact.
Take a look at Do Until and Do While and While.
If you really want to iterate over cells you may go ahead. But here a method using Arrays, this will by all means reduces any performance drops that you would get looping over cells...
Option Explicit
Sub AddToRigh()
Dim i As Integer
Dim vArr As Variant
Dim LastRow As Long
'--assume you are working on Sheet 1
LastRow = Sheets(1).Cells(Rows.Count, Range("A1").Column).End(xlUp).Row
ReDim vArr(1 To LastRow)
For i = LBound(vArr) To UBound(vArr)
vArr(i) = "=Sum(RC[-2]:RC[-1])"
Next i
'--output this entire array with formulas into column C
Sheets(1).Range("C1").Resize(UBound(vArr)) = Application.Transpose(vArr)
End Sub
Output:
I'm by no means an expert in vba, but you could do this:
Sub macro()
Dim R As Long
R = 1
Do While Not IsEmpty(ActiveCell.Offset(0, -2))
Cells(R, "C").Select
R = R + 1
ActiveCell.Formula = "=sum(" & ActiveCell.Offset(0, -2) & "," &
ActiveCell.Offset(0, -1) & ")"
Loop
End Sub
I thought I'd recommend a slightly different course of action, just to give you ideas :):
Sub macro()
Dim found As Range
Set found = Range("A:A").Find("*", after:=Range("A1"), searchdirection:=xlPrevious)
If Not found Is Nothing Then
Range(Range("A1"), found).Offset(0, 2).FormulaR1C1 = "=RC[-2]+RC[-1]"
End If
End Sub