on Excel I'm trying to "Find and Replace" some text (the text is the same for every cell) and change it to multiple cells (600+ cells). The problem is that when I do it excel removes the formatting from the text.
I searched something and apparently you can do it via VBA, so I found this VBA Macro:
Sub CharactersReplace(Rng As Range, FindText As String, ReplaceText As String, Optional MatchCase As Boolean = False)
'UpdatebyExtendoffice20160711
Dim I As Long
Dim xLenFind As Long
Dim xLenRep As Long
Dim K As Long
Dim xValue As String
Dim M As Long
Dim xCell As Range
xLenFind = Len(FindText)
xLenRep = Len(ReplaceText)
If Not MatchCase Then M = 1
For Each xCell In Rng
If VarType(xCell) = vbString Then
xValue = xCell.Value
K = 0
For I = 1 To Len(xValue)
If StrComp(Mid$(xValue, I, xLenFind), FindText, M) = 0 Then
xCell.Characters(I + K, xLenFind).Insert ReplaceText
K = K + xLenRep - xLenFind
End If
Next
End If
Next
End Sub
Sub Test_CharactersReplace()
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Select a range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Call CharactersReplace(xRg, "<span style="background-color: #ffff00;">##</span>", "<span style="background-color: #ffff00;">asdasd</span>", True)
End Sub
(I posted a picture because I dont know how to paste the entire code with the CTRL+K command).
The code seems ok but is red on the last line of Code (on the line where I have to decide which word it will be changed).
Any suggestion ?
Thank you very much
The last line of code should be:
Call CharactersReplace(xRg, "<span style=""background-color: #ffff00;"">KK</span>"", ""<span style=""background-color: #ffff00;"">Kutools</span>", True)
Where every " inside the outermost quotes is doubled.
To answer the question you posted in the comments, Alt+Enter is equivalent to vbLf or Chr(10) in VBA.
Related
I am writing a check in/out program in excel and have gotten te request that if a line contains "|0|" it should get a different font color.
I've tried with Instr and Cells().Characters but I cannot seem to figure out how to do it.
The cells can have a variety of rows of text. Which is easy enough to solve with splitting them on a return and having a for loop loop, but I cannot seem to figure out how to assign a different font color to a row of text that contains the required value.
Image for illustration of the data:
How do I best solve this?
Added information:
The goal of this is that on button press the whole line of text where the |O| is would be collored differently. Other lines of text that do not have this will remain the same color.
Like in this image as a concept
[]
try this
Public Sub ExampleMainSub()
Dim cell As Range
For Each cell In Selection
If HasMySymbols(cell.Value) Then
WorkWithCellContent cell
Else
cell.Font.ColorIndex = xlAutomatic
cell.Font.TintAndShade = 0
End If
Next cell
End Sub
Private Sub WorkWithCellContent(ByVal cell As Range)
Dim arr As Variant
arr = Split(cell.Value, Chr(10))
Dim firstPosOfRow As Long
firstPosOfRow = 1
Dim subLine As Variant
For Each subLine In arr
If HasMySymbols(subLine) Then
cell.Characters(start:=firstPosOfRow, Length:=Len(subLine)).Font.Color = vbRed
Else
cell.Characters(start:=firstPosOfRow, Length:=Len(subLine)).Font.ColorIndex = xlAutomatic
End If
firstPosOfRow = firstPosOfRow + Len(subLine) + 1 '+1 is needed
Next subLine
End Sub
Private Function HasMySymbols(ByVal somestring As String) As Boolean
HasMySymbols = InStr(1, somestring, "|0|") > 0
End Function
Try this. It works for me.
Sub ChangeRowFontColour()
Dim rng As Range
Dim TextToFind As String
Dim FirstFound As String
TextToFind = "Specific Text"
With ActiveSheet.UsedRange
Set rng = .Cells.Find(TextToFind, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstFound = rng.Address
Do
rng.EntireRow.Font.ColorIndex = 3
For Each part In rng
lenOfPart = Len(part)
lenTextToFind = Len(TextToFind)
For i = 1 To lenOfPart
tempStr = Mid(part, i, lenTextToFind)
If tempStr = TextToFind Then
part.Characters(Start:=i, Length:=lenTextToFind).Font.ColorIndex = 0
End If
Next i
Next
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstFound
End If
End With
End Sub
I am trying to format and split a column of excel cells vertically. Each cell contains starts ICD-10: and then lots of codes separated with commas ",". I would like to Removed the ICD-10: and all of the spaces resulting in a column of just the individual codes. I found the following VBA code and have modified it to partly. I need to help removing the unwanted spaces and "ICD-10:" from the out put. I tried using trim and replace but I don't have a super firm understanding of exactly how this is working I just know it is close.
Any help is greatly appreciated.
Sub splitvertically()
'updatebyExtendoffice
Dim xRg As Range
Dim xOutRg As Range
Dim xCell As Range
Dim xTxt As String
Dim xStr As String
Dim xOutArr As Variant
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOutRg = Application.InputBox("please select output cell:", "Kutools for Excel", , , , , , 8)
If xOutRg Is Nothing Then Exit Sub
For Each xCell In xRg
If xStr = "" Then
xStr = xCell.Value
Else
xStr = xStr & "," & xCell.Value
End If
Next
xOutArr = VBA.Split(xStr, ",")
xOutRg.Range("A1").Resize(UBound(xOutArr) + 1, 1) = Application.WorksheetFunction.Transpose(xOutArr)
End Sub
Sample Data
A1 = ICD-10: S7291XB, I4891, S0101XA, S7291XB, Z7901, V0300XA
A2 = ICD-10: S72431C, D62, E0590, E43, E785, E872, F321, G4700, I129, I2510, I441, I4891, I4892, I959, N183, R339, S0101XA, S01111A, S32591A, S7010XA, S72431C, Z6823, Z7901, Z87891, Y92481, S72351B
Thanks for the help.
You have a very good beginning. With only 3 more lines of code, we can make it happen. I don't know what happens then the output range xOutRg is more than one cell.
Option Explicit ' ALWAYS
Sub splitvertically()
'updatebyExtendoffice
Dim xRg As Range
Dim xOutRg As Range
Dim xCell As Range
Dim xTxt As String
Dim xStr As String
Dim xOutArr As Variant
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOutRg = Application.InputBox("please select output cell:", "Kutools for Excel", , , , , , 8)
If xOutRg Is Nothing Then Exit Sub
For Each xCell In xRg
'just get the input value(s), then remove ICD-10, then remove any spaces
xTxt = xCell.Value
xTxt = Replace(xTxt, "ICD-10:", "")
xTxt = Replace(xTxt, " ", "")
' then append xTxt (not original cell)
If xStr = "" Then
xStr = xTxt
Else
xStr = xStr & "," & xTxt
End If
Next
xOutArr = VBA.Split(xStr, ",")
xOutRg.Range("A1").Resize(UBound(xOutArr) + 1, 1) = Application.WorksheetFunction.Transpose(xOutArr)
End Sub
Here's code that will split the cells in the way you describe. It works very fast but please take the time to read all the comments carefully. Some of them are just informative but others may require your action. In this regard, pay attention to the names I have given to the variables. A name like FirstDataRow will help you know what you should adjust.
Sub SplitCellsToList()
Const FirstDataRow As Long = 2 ' change to suit
Const InputColumn As Long = 1 ' change to suit (1 = column A)
Dim OutCell As Range ' first cell of output list
Dim InArr As Variant ' array of input values
Dim OutArr As Variant ' array of output values
Dim n As Long ' row index of OutArr
Dim Sp() As String ' Split cell value
Dim i As Integer ' index of Split
Dim R As Long ' loop counter: sheet rows
Set OutCell = Sheet1.Cells(2, "D") ' change to suit
With ActiveSheet
InArr = .Range(.Cells(FirstDataRow, InputColumn), _
.Cells(.Rows.Count, InputColumn).End(xlUp)).Value
End With
ReDim OutArr(1 To 5000) ' increase if required
' 5000 is a number intended to be larger by a significant margin
' than the total number of codes expected in the output
For R = 1 To UBound(InArr)
Sp = Split(InArr(R, 1), ":")
If UBound(Sp) Then
Sp = Split(Sp(1), ",")
For i = 0 To UBound(Sp)
Sp(i) = Trim(Sp(i))
If Len(Sp(i)) Then
n = n + 1
OutArr(n) = Sp(i)
End If
Next i
Else
' leave the string untreated if no colon is found in it
n = n + 1
OutArr(n) = InArr(R, 1)
End If
Next R
If n Then
ReDim Preserve OutArr(1 To n)
OutCell.Resize(n).Value = Application.Transpose(OutArr)
End If
End Sub
I'm trying to create a vba script that will search for the _ in all the cells fallen under Crude Items column. However, when it finds one, it will split the values from _ and place the rest in corresponding cells fallen under Refined Ones column.
I've tried with the following which is doing the job flawlessly but I wish to search and replace the values using column headers:
Sub CopyAndReplace()
Dim cel As Range
For Each cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).row)
If cel.value <> "" Then
Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
End If
Next cel
End Sub
To let you visualize how the sheet might look like:
How can I search and replace the values using column headers?
I am not sure this is what you are after, but a few important mentions...
Try to always use at least a worksheet qualifier when writing your code. How else is your program going to know explicitly where you would like it to operate?
I have changed your process slightly, but again, not sure if this is exactly what you are after. See below code.
Sub SplitByHeader()
Dim i As Long
Dim crudeHeader As Range, refinedHeader As Range
Dim ws As Worksheet
'set ws
Set ws = ThisWorkbook.Sheets("Sheet1")
'set header ranges
Set crudeHeader = ws.Rows(1).Find(What:="Crude Items", LookAt:=xlWhole)
Set refinedHeader = ws.Rows(1).Find(What:="Refined Ones", LookAt:=xlWhole)
'simple error handler
If crudeHeader Is Nothing Or refinedHeader Is Nothing Then Exit Sub
For i = 2 To ws.Cells(ws.Rows.Count, crudeHeader.Column).End(xlUp).Row
If ws.Cells(i, crudeHeader.Column).Value <> "" Then
ws.Cells(i, refinedHeader.Column).Value = Split(ws.Cells(i, crudeHeader.Column).Value, "_")(1)
End If
Next i
End Sub
I have just tried this one with the code below:
It is a good idea to add additional check to the condition, like this - If myCell.Value <> "" And InStr(1, myCell, "_") Then to avoid starting from A2.
The idea is that the LocateValueCol locates the column of the first row, which has the string, passed to it. Knowing this, it works ok.
Option Explicit
Sub CopyAndReplace()
Dim searchColumn As Long
searchColumn = LocateValueCol("SearchCol", Worksheets(1))
Dim replaceColumn As Long
replaceColumn = LocateValueCol("ReplaceCol", Worksheets(1))
Dim myCell As Range
Dim lastCell As Long
With Worksheets(1)
lastCell = .Cells(.Rows.Count, searchColumn).End(xlUp).Row
For Each myCell In .Range(.Cells(1, searchColumn), .Cells(lastCell, searchColumn))
If myCell.Value <> "" And InStr(1, myCell, "_") Then
.Cells(myCell.Row, replaceColumn) = Split(myCell, "_")(1)
End If
Next
End With
End Sub
This is the function, locating the columns. (If you have ideas for improvement, feel free to make a PR here):
Public Function LocateValueCol(ByVal textTarget As String, _
ByRef wksTarget As Worksheet, _
Optional rowNeeded As Long = 1, _
Optional moreValuesFound As Long = 1, _
Optional lookForPart = False, _
Optional lookUpToBottom = True) As Long
Dim valuesFound As Long
Dim localRange As Range
Dim myCell As Range
LocateValueCol = -999
valuesFound = moreValuesFound
Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.Count))
For Each myCell In localRange
If lookForPart Then
If textTarget = Left(myCell, Len(textTarget)) Then
If valuesFound = 1 Then
LocateValueCol = myCell.Column
If lookUpToBottom Then Exit Function
Else
Decrement valuesFound
End If
End If
Else
If textTarget = Trim(myCell) Then
If valuesFound = 1 Then
LocateValueCol = myCell.Column
If lookUpToBottom Then Exit Function
Else
Decrement valuesFound
End If
End If
End If
Next myCell
End Function
Private Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1)
valueToIncrement = valueToIncrement + incrementWith
End Sub
Private Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1)
valueToDecrement = valueToDecrement - decrementWith
End Sub
For fun using regex and dynamically finding header columns. You can swop out the regex based function for your own and still have the dynamic column finding.
Option Explicit
Public Sub test()
Dim i As Long, inputs(), re As Object, ws As Worksheet
Dim inputColumn As Range, outputColumn As Range, inputColumnNumber As Long, outputColumnNumber As Long
Const SEARCH_ROW As Long = 1
Const INPUT_HEADER As String = "Crude items"
Const OUTPUT_HEADER As String = "Refined Ones"
Const START_ROW = 2
Set re = CreateObject("VBScript.RegExp")
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set inputColumn = GetColumnByHeader(ws, SEARCH_ROW, INPUT_HEADER)
Set outputColumn = GetColumnByHeader(ws, SEARCH_ROW, OUTPUT_HEADER)
If inputColumn Is Nothing Or outputColumn Is Nothing Then Exit Sub
inputColumnNumber = inputColumn.Column
outputColumnNumber = outputColumn.Column
With ws
inputs = Application.Transpose(.Range(.Cells(START_ROW, inputColumnNumber), .Cells(.Cells(.Rows.Count, inputColumnNumber).End(xlUp).Row, inputColumnNumber)).Value)
For i = LBound(inputs) To UBound(inputs)
inputs(i) = GetMatch(re, inputs(i))
Next
.Cells(START_ROW, outputColumnNumber).Resize(UBound(inputs), 1) = Application.Transpose(inputs)
End With
End Sub
Public Function GetColumnByHeader(ByVal ws As Worksheet, ByVal SEARCH_ROW As Long, ByVal columnName As String) As Range
Set GetColumnByHeader = ws.Rows(SEARCH_ROW).Find(columnName)
End Function
Public Function GetMatch(ByVal re As Object, ByVal inputString As String) As String
With re
.Global = True
.MultiLine = True
.Pattern = "_(.*)"
If .test(inputString) Then
GetMatch = .Execute(inputString)(0).SubMatches(0)
Else
GetMatch = inputString 'or =vbNullString if want to return nothing
End If
End With
End Function
If you are working through an actual table things will become quite easy:
Sub Test()
Dim arr(), x As Long
With ThisWorkbook.Sheets("Sheet1") 'Change accordingly
For Each cl In .Range("Table1[Crude Items]") 'Change Table1 accordingly
ReDim Preserve arr(x)
If InStr(cl, "_") > 0 Then
arr(x) = Split(cl, "_")(1)
Else
arr(x) = ""
End If
x = x + 1
Next cl
.Range("Table1[Refined Ones]").Value = Application.Transpose(arr)
End With
End Sub
There is a check for "_". If not there, the cell will be kept empty.
You can also consider to use formula to do it.
I am not clear about what you want to replace "_" character with. For example, iff you replace the following line of your script:
Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
with this one:
Sheets("Sheet1").Range(cel(1, 3).Address) = WorksheetFunction.Substitute(cel, "_", "")
The above line should replace the "_" character with nothing from the cells in the Crude_Items column
And as Lee said, you can also consider using formula in the worksheet if you do not have significant amount of data
I am trying to build a simple macro that converts a selected range with numeric values to a "0000" format (e.g. 50,75,888, 1000 would be 0050,0075, 0888, 1000) i.e. it picks up each value in each cell and and returns a string value back to the sheet which can then be manipulated in Excel
Almost there (I think..) I just need help with the the $format function
Sub LeadingZero()
Dim RngSelected As Range
Dim R As String
Dim RCell As Range
Dim Rrng As Range
Dim RevNum As Long
On Error Resume Next
Set RngSelected = Application.InputBox("Please select a range of cells you want to convert to 0000 format", _
"SelectRng", Selection.Address, , , , , 8)
R = RngSelected.Address
Set Rrng = Range(R)
For Each RCell In Rrng.Cells
RCell.Value = Format$(RCell, "0000") 'this is the line I want to work!
'RCell.Value2 = Format$(RCell, "0000") doesn't seem to work either
Next RCell
End Sub
Thanks
Did you specifically want to do it with formatting? If you actually want to convert the value (useful for lookup and the like) then this function will do what you want.
Function FourDigitValues(InputString As String)
Dim X As Long, MyArr As Variant
MyArr = Split(InputString, ",")
For X = LBound(MyArr) To UBound(MyArr)
MyArr(X) = Right("0000" & MyArr(X), 4)
Next
FourDigitValues = Join(MyArr, ",")
End Function
Sub LeadingZero()
Dim RngSelected As Range
Dim R As String
Dim RCell As Range
Dim Rrng As Range
Dim RevNum As Long
On Error Resume Next
Set RngSelected = Application.InputBox("Please select a range of cells you want to convert to 0000 format", _
"SelectRng", Selection.Address, , , , , 8)
R = RngSelected.Address
Set Rrng = Range(R)
For Each RCell In Rrng.Cells
RCell.NumberFormat = "000#"
Next RCell
End Sub
Thanks to Assaf and Dan Donoghue:
Sub LeadingZero2()
'Takes a range with numbers between 1 and 9999 and changes them to text string with "0000" format
Dim RngSelected As Range
Dim RCell As Range
Dim Rrng As Range
On Error Resume Next
Set RngSelected = Application.InputBox("Please select a range of cells you want to convert to 0000 format", _
"SelectRng", Selection.Address, , , , , 8)
Set Rrng = Range(RngSelected.Address)
For Each RCell In Rrng.Cells
RCell.NumberFormat = "#"
RCell = CStr(Array("000", "00", "0")(Len(RCell) - 1) & RCell)
Next RCell
End Sub
I want to be able to export a selected range of cells to a .csv file using VBA. What I have come up with so far does the job excellently for cohering selections, but fails misearably when multiple columns are selected.
Here is the code I managed to put together from snippets found on the internet: It also fiddles around with some UI and since my Excel speaks German and I need to have "." as decimal separator instead of "," it tweaks that.
Sub Range_Nach_CSV_()
Dim vntFileName As Variant
Dim lngFN As Long
Dim rngRow As Excel.Range
Dim rngCell As Excel.Range
Dim strDelimiter As String
Dim strText As String
Dim strTextCell As String
Dim strTextCelll As String
Dim bolErsteSpalte As Boolean
Dim rngColumn As Excel.Range
Dim wksQuelle As Excel.Worksheet
Dim continue As Boolean
strDelimiter = vbtab
continue = True
Do While continue = True
vntFileName = Application.GetSaveAsFilename("Test.txt", _
FileFilter:="TXT-File (*.TXT),*.txt")
If vntFileName = False Then
Exit Sub
End If
If Len(Dir(vntFileName)) > 0 Then
Dim ans As Integer
ans = MsgBox("Datei existiert bereits. Überschreiben?", vbYesNo)
If ans = vbYes Then
continue = False
ElseIf ans = vbNo Then
continue = True
Else
continue = False
End If
Else
continue = False
End If
Loop
Set wksQuelle = ActiveSheet
lngFN = FreeFile
Open vntFileName For Output As lngFN
For Each rngRow In Selection.Rows
strText = ""
bolErsteSpalte = True
For Each rngCell In rngRow.Columns
strTextCelll = rngCell.Text
strTextCell = Replace(strTextCelll, ",", ".")
If bolErsteSpalte Then
strText = strTextCell
bolErsteSpalte = False
Else
strText = strText & strDelimiter & strTextCell
End If
Next
Print #lngFN, strText
Next
Close lngFN
End Sub
As I already mentioned the sub works well with coherent selections and also with multiple selected lines, but fails when it comes to multiple columns.
The current output of the sub can be seen on this here picture:
multiple columns failed
As one would expect, I want the .csv-file (or respective .txt-file) to look like this:
multiple columns desired output
How can I achieve the desired behaviour for the last case?
And would someone be so kind to include the links as images? If perceived appropriate, of course.
This might seem a little complex, but your use case isn't very simple...
It does assume that each of the selected areas is the same size, and that they all line up (as either rows or columns)
Sub Tester()
Dim s As String, srow As String, sep As String
Dim a1 As Range, rw As Range, c As Range, rCount As Long
Dim areaCount As Long, x As Long
Dim bColumnsSelected As Boolean
Dim sel As Range
bColumnsSelected = False
Set sel = Selection
areaCount = Selection.Areas.Count
Set a1 = Selection.Areas(1)
If areaCount > 1 Then
If a1.Cells(1).Column <> Selection.Areas(2).Cells(1).Column Then
'areas represent different columns (not different rows)
bColumnsSelected = True
Set sel = a1
End If
End If
rCount = 0
For Each rw In sel.Rows
rCount = rCount + 1
srow = ""
sep = ""
For Each c In rw.Cells
srow = srow & sep & Replace(c.Text, ",", ".")
sep = ","
Next c
'if there are multiple areas selected (as columns), then include those
If bColumnsSelected Then
For x = 2 To areaCount
For Each c In Selection.Areas(x).Rows(rCount).Cells
srow = srow & sep & Replace(c.Text, ",", ".")
Next c
Next x
End If
s = s & IIf(Len(s) > 0, vbCrLf, "") & srow
Next rw
Debug.Print s
End Sub