Removing all data before the first '-' in a column in VBA - excel

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

Related

Using Index Match to get the Desired Result from the Date

I have been striving hard to make a formula which match the dates and populate the index.
I have created this formula but if there are more then similar two dates or three or more in the data then how the data for all the similar dates will be populated in the cell.
I have attached a sheet where 1st Table has Data, 2nd is my table where i have applied below formula and third table is the accurate example the result i have been looking for.
Your help will be appreciated.
=IFERROR(INDEX(C2:C92,MATCH(F3,A2:A92,0)))
Link:
https://docs.google.com/spreadsheets/d/1WT7MJuNqspJGU6wLtKQRp2BxpuiRknkEKfZR4MZd-0A/edit?usp=sharing
If you have Office 365 then in cell F3 put:
=TEXTJOIN(CHAR(10),TRUE,IF($A$2:$A$92=E3,$C$2:$C$92,""))
and in cell G3 put:
=TEXTJOIN(CHAR(10),TRUE,IF($A$2:$A$92=E3,($B$2:$B$92*100)&"%",""))
Please note that percentage is not actual percentage but a concatenated string in the output formula.
EDIT
You can try below UDF if you don't have TEXTJOIN
Public Function ConcatStringConditional(rngCritCol As Range, rngCrit As Range, rngConcat As Range) As String
Dim i As Long
For i = 1 To rngCritCol.Cells.Count
If rngCritCol.Cells(i, 1).Value2 = rngCrit.Value2 Then
If Len(ConcatStringConditional) > 0 Then
ConcatStringConditional = ConcatStringConditional & vbCrLf & Format(rngConcat.Cells(i, 1).Value, rngConcat.Cells(i, 1).NumberFormat)
Else
ConcatStringConditional = Format(rngConcat.Cells(i, 1).Value, rngConcat.Cells(i, 1).NumberFormat)
End If
End If
Next i
End Function
This shall be copied to a module in Visual Basic Editor by choosing Insert|Module. You can google to see the procedure if you are unsure. Once put in a module then it can be used like a normal formula e.g.
=ConcatStringConditional($A$2:$A$92,E4,$C$2:$C$92)
This is basic functionality, please feel free to edit to your requirements further.
Note: Macros must be enabled for the UDF to run properly!
Please, try the next UDF function. It uses array and will be very fast, for big ranges:
Function bringData(D As Range, Optional X As String) As String
Dim sh As Worksheet, arr, lastR As Long, i As Long, strD As String
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.Count).End(xlUp).row
arr = sh.Range("A2:C" & lastR).value
For i = 1 To UBound(arr)
If CDate(arr(i, 1)) = CDate(D.value) Then
strD = strD & IIf(X = "D", arr(i, 3), arr(i, 2) * 100 & "%") & vbLf
End If
Next i
If strD <> "" Then
strD = left(strD, Len(strD) - 1)
bringData = strD
Else
bringData = "No Match"
End If
End Function
It can be called in the next way:
To obtain the Data (per date) the formula will be:
=bringData(E2,"D")
In order to bring the percentage, the formula should be:
=bringData(E2)
The above code assumes that the first Table is in the range "A:C" and the the second one in the range "E:G", starting from the second row...
If in different ranges, the code should be easy to adapt, I think. If not clear enough, do not hesitate to ask.
Please, test it and send some feedback.
Edited:
Try the next code for the three options. Use "D", "D2" or nothing like the second function parameter:
Function bringData(D As Range, Optional X As String) As String
Dim Sh As Worksheet, arr, lastR As Long, i As Long, strD As String
Set Sh = ActiveSheet
lastR = Sh.Range("A" & Sh.rows.Count).End(xlUp).row
arr = Sh.Range("A2:D" & lastR).value
For i = 1 To UBound(arr)
If CDate(arr(i, 1)) = CDate(D.value) Then
strD = strD & IIf(X = "D", arr(i, 3), IIf(X = "D2", arr(i, 4), arr(i, 2) * 100 & "%")) & vbLf
End If
Next i
If strD <> "" Then
strD = left(strD, Len(strD) - 1)
bringData = strD
Else
bringData = "No Match"
End If
End Function
I will be available only after 3 - 4 hours...

Reducing number of Line Breaks/chr(10) in a Cell

I have an excel sheet that has cells with variable amounts of line breaks and I want to reduce it so that there is only one line break between each new line.
For example
HELLO
WORLD
GOODBYE
will be modified to:
HELLO
WORLD
GOODBYE
I've been banging my head over this for hours and have come up with a few ways but none are very efficient or produce the best results.
This is made especially difficult because I'm working with a dataset that has spaces preceeding the Line Breaks.
And so a regular parse doesn't work as well.
I've tried to replace all the instances of chr(10) in the cell with ~ to make it easier to work with, however i'm still not getting it to an exact amount. I'm wondering if there are better ways.
here is what I have so far:
myString = Replace(myString, Chr(10), "~")
Do While InStr(myString, "~~") > 0
str1 = Split(myString, "~")
For k = 0 To UBound(str1)
myString = Replace(myString, "~~", "~")
Next k
Loop
Do While InStr(myString, " ~") > 0
str1 = Split(myString, "~")
For k = 0 To UBound(str1)
myString = Replace(myString, " ~", "")
Next k
Loop
myString = Replace(myString, " ~", " ~")
myString = Replace(myString, " ~", "~")
myString = Replace(myString, "~", Chr(10))
Cells(2, 2).Value = myString
So i'm using a few do while loops to catch instances of different types of line breaks (or in this case, tildes) but I don't think this is the best way to tackle this.
I was thinking of ways to loop through the characters in the cell, and if there is an instance where there is more than one chr(10), replace it with "".
So the psuedocode would look like:
for i to len(mystring)
if mystring(i) = chr(10) AND myString(i+1) = chr(10) Then
myString(i + 1) = ""
but unfortunately I don't think this is possible through vba.
If anyone is kind enough to help me adjust my current code or assist me with the aforementioned psuedocode, it would be greatly appreciated!
You can do it with a formula:
=SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(TRIM(A1)," ","|"),"|"&CHAR(10)," "),CHAR(10)," "))," ",CHAR(10)),"|"," ")
This changes all the spaces to | and then the Char(10) to spaces. The trim removes the extra spaces. The we reverse, space to Char(10) and | to spaces.
VBA:
Function manytoone(str As String)
str = Replace(Application.Trim(str), " ", "|")
str = Replace(str, "|" & Chr(10), " ")
str = Replace(str, Chr(10), " ")
str = Application.Trim(str)
str = Replace(str, " ", Chr(10))
str = Replace(str, "|", " ")
manytoone = str
End Function
You can use Regular Expressions.
The regex pattern below removes any line that contains zero to any number of spaces, along with its terminating crlf, and also removes the crlf at the end of the final word.
Option Explicit
Sub trimXSLF()
Dim myRng As Range, myCell As Range, WS As Worksheet
Dim RE As Object
Const sPat As String = "^\s*[\x0A\x0D]+|[\x0A\x0D](?!\s*\S+\s*)"
Const sRepl As String = ""
Set WS = Worksheets("sheet4") 'or whatever
With WS
Set myRng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = True
.MultiLine = True
.Pattern = sPat
For Each myCell In myRng
myCell = .Replace(myCell.Value2, sRepl)
Next myCell
End With
End Sub
If myRng is large (tens of thousands of rows), the macro could run the process over a VBA array for speed.
A VBA method would be replacing consecutive vbLf constants with a single one.
Loop through the string as long as there are more than one vbLf together, once removed, replace the string.
Sub RemoveExcessLinebreaks()
Dim s As String, rng As Range
Set rng = ThisWorkbook.Worksheets(1).Range("B4")
s = rng.Value
While InStr(1, s, vbLf & vbLf) > 0
s = Replace(s, vbLf & vbLf, vbLf)
Wend
rng.Value = s
End Sub
Obviously, you would need to modify the rng object to your purposes, or turn it into a parameter to the sub itself.
vbLf is a constant for a "LineFeed". There are multiple types of new lines, such as a vbCr (Carriage Return) or a vbCrLf (combined). Pressing Alt + Enter in a cell appears to use the vbLf variant, which is why I used this constant over the others.
This has already been answered fairly well, but not meeting one of the requirements yet (have 1 line between each new line), so here is my take on answering this. Please see the comments through the code for more details:
Option Explicit
Sub reduceNewLines()
Dim ws As Worksheet: Set ws = ActiveWorkbook.Sheets("Sheet1")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim lCol As Long: lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Dim arrData As Variant: arrData = ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol))
Dim arrVal() As String
Dim R As Long, C As Long, X As Long
For R = LBound(arrData) To UBound(arrData) 'Iterate through each row of data
For C = LBound(arrData, 2) To UBound(arrData, 2) 'iterate through each column of data (though might be just 1)
arrVal = Split(arrData(R, C), Chr(10)) 'allocate each row to an array, split at new line
arrData(R, C) = "" 'reset the data inside this field
For X = LBound(arrVal) To UBound(arrVal)
arrVal(X) = Trim(arrVal(X)) 'clear leading/trailing spaces
If Left(arrVal(X), 1) <> " " And arrVal(X) <> "" Then
arrData(R, C) = arrData(R, C) & arrVal(X) & Chr(10) & Chr(10) 'allocate new data + 2 lines
End If
Next X
arrData(R, C) = Left(arrData(R, C), Len(arrData(R, C)) - 2) 'remove the last 2 extra new lines
Next C
Next R
ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol)) = arrData 'allocate the data back to the sheet
End Sub
Happy to assist further if needed.

Move Two characters from beginning to end of string VBA

I need to create a VBA script in excel that chanages an order number from having "CD" at the front to "CD" at the end so from "CD00001" to "00001CD"
Any help would be awesome. all of the order numbers are in Column B and start at row 5. please help.
What i have so far:
Private Sub OrderNumber_Click()
Dim Val As String
Dim EndC As Integer
EndC = Worksheets("Raw Data Upload").Range("A1048576").End(xlUp).Row
For i = 5 To EndC
Val = Right("B" & i, Len("B" & i) - 2) & Left("B" & i, 2)
Range("B" & i).Value = Val
Next
End Sub
This replaces the order numbers with B5, B6 and so on but if i put this function into Excel itself it works fine.
Like this? DO you want it in column B?
Option Explicit
Private Sub OrderNumber_Click()
Dim i As Long
Dim val As String
Dim EndC As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Raw Data Upload")
EndC = ws.Range("A1048576").End(xlUp).Row
For i = 5 To EndC
val = ws.Cells(i, "A")
Range("B" & i).Value = Mid$(val, 3, Len(val) - 2) & Left$(val, 2)
Next i
End Sub
dim beginStr, endStr, originalStr, outputStr as string
dim rng as range
'put the below into a loop, assigning a rng to the desired cell each time
originalStr = rng.value ' Change to chosen range
beginStr = left(originalStr,2)
endStr = right(originalStr, len(originalStr) - 2)
outputStr = endStr + beginStr
Range("B" & i).Value = outputStr
I haven't got a copy of Excel to test this on but it should work.
Simply use:
Right(Range("B" & i), Len(Range("B" & i)) - 2) & Left(Range("B" & i), 2)
An alternative is to set up the cell as a Range():
Sub t()
Dim cel As Range
Dim endC As Long
endC = Worksheets("Raw Data Upload").Range("A1048576").End(xlUp).Row
For i = 5 To endC
Set cel = Range("B" & i)
myVal = Right(cel, Len(cel) - 2) & Left(cel, 2)
Range("B" & i).Value = myVal
Next
End Sub
Currently, when you do Right("B" & i, Len("B" & i) - 2) & Left("B" & i, 2), for row 5, this becomes Right("B5", Len("B5") - 2) & Left("B5", 2) then this evaluates to simply:
Right("B5",0) & Left("B5",2), which is
[nothing] & B5, finally becoming
B5
Note the lack of using B5as a range. Instead it's being treated as a string.
(Also, I'm assuming this is to be run on the ActiveSheet. If not, please add the worksheet before the range, i.e. Worksheets("Raw Data Upload").Range("B" & i)...)
Try this
Private Sub OrderNumber_Click()
Dim cell As Range
With Worksheets("Raw Data Upload")
For Each cell in .Range("B5", .Cells(.Rows.Count, 2).End(xlUp))
cell.Value = Right(cell.Value, Len(cell.Value) - 2) & Left(cell.Value, 2)
Next
End With
End Sub

Excel VBA - add zero's inbetween two values

I've done quite a bit of searching around for this one...and I'm not getting anywhere.
I have a spreadsheet(specific column) with values such as:
42153-95
54126-3
13613-6331
16136-336
My goal is to add zero's after the - and before the existing #'s(to 4 places). Like:
42153-0095
54126-0003
13613-6331
16136-0336
I've tried a a lot of different options within the quotes of NumberFormat:
Worksheets("Sheet1").Columns("C"). _ NumberFormat = "00000-0000"
No luck so far. :(
Any help would be greatly appreciated.
Thanks!
Sub testFunc()
MsgBox addZero("54126-3")
End Sub
'/ Function to add Zeros
Public Function addZero(strVal As String) As String
Dim arrTemp
Dim strTemp
arrTemp = Split(strVal, "-")
strTemp = arrTemp(0) & "-" & String(4 - Len(arrTemp(1)), "0") & arrTemp(1)
addZero = strTemp
End Function
As #tigeravatar stated it can be done with a formula. With the Evaluate function we can use an array form of the formula he gave in his comment.
You can apply this to your values in column C:
Worksheets("Sheet1").Range("C1:C4").Value = Worksheets("Sheet1").Evaluate("=INDEX(LEFT(C1:C4,6) & TEXT(--MID(C1:C4,7,LEN(C1:C4)),""0000""),)")
If your range is dynamic and you have the final row in a variable like lstrow you can replace all the C4 with C" & lstrow & "
Worksheets("Sheet1").Range("C1:C" & lstrow).Value = Worksheets("Sheet1").Evaluate("=INDEX(LEFT(C1:C" & lstrow & ",6) & TEXT(--MID(C1:C" & lstrow & ",7,LEN(C1:C" & lstrow & ")),""0000""),)")
Select the cells you wish to process and run:
Sub dural()
Dim r As Range
bry = Array("0000", "000", "00", "0", "")
For Each r In Selection
ary = Split(r.Value, "-")
ary(1) = bry(Len(ary(1))) & ary(1)
r.Value = Join(ary, "-")
Next r
End Sub
Before:
and after:

Excel trick for this task

I've got a spreadsheet in excel with this rows:
COLUMN
Value1.Value2.Value3
Value4.Value5.Value6
Value7.Value8.Value9
In another spreadsheet I've got a simple list with names:
COLUMN
Name1
Name2
Name3
And,of course, this list is huge :).
So need to have the following spreasdsheet at the end:
COLUMN
Value1.Name1.Value2.Value3
Value4.Name1.Value5.Value6
Value7.Name1.Value8.Value9
Value1.Name2.Value2.Value3
Value4.Name2.Value5.Value6
Value7.Name2.Value8.Value9
Value1.Name3.Value2.Value3
Value4.Name4.Value5.Value6
Value7.Name4.Value8.Value9
I have to concatenate the names on the list with all the values on spreadsheet replicating them for ALL the names.
Is there a way of doing this process automatically? The manual process would take hours to be done and I think there's a smarter way of doing that although I don't know it! :)
Thanks in advance for your help.
And it is a good challenge to do it with formulas: :)
With this array formula in D1 and then copy down
=INDEX(LEFT($A$1:$A$4;FIND(".";$A$1:$A$4))&TRANSPOSE($C$1:$C$3)&RIGHT($A$1:$A$4;LEN($A$1:$A$4)-FIND(".";$A$1:$A$4)+1);1+INT((ROWS($D$1:D1)-1)/ROWS($C$1:$C$3));1+MOD(ROWS($D$1:D1)-1;ROWS($C$1:$C$3)))
Depending on your regional settings you may need to replace field separator ";" by ","
There is always a "." between the values.
Try this code. Using arrays would be much faster for huge list of names/values:
Sub test()
Dim arrVal As Variant
Dim arrNames As Variant
Dim arrRes As Variant
Dim v, n, k As Long
'change Sheet1 to suit
With ThisWorkbook.Worksheets("Sheet1")
'change A1:A3 to values address
arrVal = .Range("A1:A3")
'change B1:B3 to names address
arrNames = .Range("B1:B3")
ReDim arrRes(1 To UBound(arrVal) * UBound(arrNames), 1 To 1)
k = 1
For Each v In arrVal
For Each n In arrNames
arrRes(k, 1) = Left(v, InStr(1, v, ".")) & n & Mid(v, InStr(1, v, "."))
k = k + 1
Next
Next v
'change "c1" to start cell where to put new values
.Range("C1").Resize(UBound(arrRes, 1)) = arrRes
End With
End Sub
Note:
If you don't know exact addresses of "values" and "name" ranges, change this part
'change A1:A3 to values address
arrVal = .Range("A1:A3")
'change B1:B3 to names address
arrNames = .Range("B1:B3")
to
'change A1:A to "values" address
arrVal = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
'change B1:B to "names" address
arrNames = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
In that case "values" and "name" ranges starts from A1 and B1 accordingly and ends in the last non empty row in coumns A and B accordingly.
Result:
I think that could work.
Const FIRST_TALBE = 4
Const SECOND_TABLE = 2
Sub makeTheJob()
For i = 1 To lastRow
l = Split(Cells(i, FIRST_TABLE), ".")
newvalue = l(0) & "." & Cells(i, SECOND_TABLE) & "." & l(1) & "." & l(2)
Debug.Print newvalue
Next i
End Sub

Resources