Macro to move number with dash to new cell - excel

In Excel, I am trying to get a macro to move numbers with a "-".
I have a column E with a list of numbers
54525841-1
454152
1365466
1254566-1
1452577-1
I want a macro to move all the numbers that have a dash or hyphen at the end to column C.
So I would need E1 54525841-1 to be moved to C1.

You'll need to change "Sheet1" to the name of the sheet where your data is.
This looks through every cell (with data) in the E column and moves the value accross to the C column if it contains a dash.
Sub MoveDashes()
Dim Sheet As Worksheet
Dim Index As Long
Set Sheet = ThisWorkbook.Worksheets("Sheet1")
For Index = 1 To Sheet.Cells(Application.Rows.Count, "E").End(xlUp).Row
If InStr(1, Sheet.Cells(Index, "E"), "-") > 0 Then
Sheet.Cells(Index, "C") = Sheet.Cells(Index, "E").Value
Sheet.Cells(Index, "E").Value = ""
End If
Next
End Sub

Does it have to be a macro? How about Advanced Filter?
Your numbers are in column E. Let's assume they have a header.
E1: Number
E2: 54525841-1
E3: 454152
E4: 1365466
E5: 1254566-1
E6: 1452577-1
In a separate area of your worksheet (let's say column G) put the following criteria:
G1: Number
G2: *-*
Your advanced filter criteria would look like this:
Anything with a "-" in it will be copied to column C.

I got it to work by this:
Sub MoveDash()
x = Range("E" & Rows.Count).End(xlUp).Row
For Each Cell In Range("E2:E" & x)
If InStr(Cell, "-") <> 0 Then
Cell.Offset(, 1) = Cell
Cell.ClearContents
End If
Next Cell
end sub

You can do this without VBA, but here is an efficient way to do it using the dictionary object.
Sub MoveNumbersWithDash()
Application.ScreenUpdating = False
Dim i As Long, lastRow As Long
Dim varray As Variant
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
lastRow = Range("E" & Rows.Count).End(xlUp).Row
varray = Range("E1:E" & lastRow).Value
For i = 1 To UBound(varray, 1)
If InStr(1, varray(i, 1), "-") <> 0 Then
dict.Add i, varray(i, 1)
End If
Next
Range("C1").Resize(dict.Count).Value = _
Application.WorksheetFunction.Transpose(dict.items)
Application.ScreenUpdating = True
End Sub
How it works:
The major theme here is avoiding calls to Excel (like a for each loop). This will make the function blazing fast (especially if you have tens and thousands of rows) and more efficient. First I locate the last cell used in E then dump the entire row into a variant array in one move. Then I loop through each element, checking if it contains a "-", if it does, I add it to a dictionary object. POINT: Add the entry as the ITEM, not KEY. This makes sure that we allow for duplicates. The variable I will be unique for each entry, so I use that as the key. Then I simple dump the entire array of cells with "-" into column C.
Why Dictionary?
The dictionary object is very fast and comes with 2 really great functions: .Keys and .Items. These will return an array of all the keys or items in the dictionary, which you can use the Transpose function on to dump an entire column of values into Excel in one step. Super efficient.

Related

Color rows red when there are duplicated values in three columns

I am struggling to color rows red when there are duplicated values
I have a table like this that might have a different number of rows in xlsm file that has several sheets, so I need to look for the right worksheet. All three rows should have the same length.
orderId
OrderNumber
PositionNumber
something1
1
1
something1
1
2
something2
1
1
something2
2
1
something2
2
1
something3
3
1
something2
2
1
The rows have the same data in all three columns, so they are duplicates that should be colourd red.
orderId
OrderNumber
PositionNumber
something2
2
1
something2
2
1
something2
2
1
Now I have been trying to colour it red, but I know next to nothing about VBA and it is hard for me to figure out how to do it.
I need to also do it for two columns in other sheet, but I guess once I can do it for three I can do it for two columns as well.
I have tried to write something, but it doesn't work.
Sub lookForDuplicates()
Dim C1 As Range, Rng As Range
Dim Value As String
For Each C1 In orders.Range("A2", orders.Range("B" & orders.Range("C", Rows.Count)).End(xlUp))
Vlu = Cl.Value & "|" & Cl.Offset(, 1).Value & "|" & Cl.Offset(, 2).Value & "|" & Cl.Offset(, 3).Value
If Vlu.exists Then
row.Interior.Color = vbRed
End If
Next C1
End Sub
You don't need VBA, you can just use Conditional Formatting with a Formula.
Imagine for a moment that these 3 Columns are A, B, and C, and you want to add a new Column, D, which says True or False, depending on whether the row is a duplicate.
If Row 2 is a duplicate, then there will be more than 1 Row where Column A contains the value from Cell A2, Column B contains the value from Cell B2, and Column C contains the value from Cell C2.
To count how many rows match those criteria, we can use a COUNTIFS function in a Worksheet Formula:
=COUNTIFS($A:$A,$A2,$B:$B,$B2,$C:$C,$C2)
To convert this into True and False if more than 1 Row matches (because, this will also count Row 2 itself!), we just need to ask it ">1?"
=COUNTIFS($A:$A,$A2,$B:$B,$B2,$C:$C,$C2)>1
And that True/False result is exactly what you need for a Conditional Formatting rule under "Use a formula to determine which cells to format"!
If you want to only colour the repeats (i.e. the second and subsequent appearance of the rows, but not the first) then you want to only check the Column so far, and not the entire Column:
=COUNTIFS($A$1:$A2,$A2,$B$1:$B2,$B2,$C$1:$C2,$C2)>1
If you want to colour the first entry in a different colour when it has repeats, then you can create another Conditional Formatting entry using an AND to contrast both versions:
=AND(COUNTIFS($A:$A,$A2,$B:$B,$B2,$C:$C,$C2)>1, NOT(COUNTIFS($A$1:$A2,$A2,$B$1:$B2,$B2,$C$1:$C2,$C2)>1))
Please, try the next code. It will color in red only rows being duplicate, I mean starting from the second occurrence of the same row content. If you need deleting the duplicate rows, you can simple replace rngRed.Interior.Color = vbRed with rngRed.EntireRow.Delete:
Sub lookForDuplicates()
Dim shO As Worksheet, lastR As Long, rng As Range, arr
Dim rngRed As Range, i As Long, dict As New Scripting.Dictionary
Set shO = ActiveSheet 'use here the sheet you need
lastR = shO.Range("A" & shO.rows.count).End(xlUp).row
Set rng = shO.Range("A2:C" & lastR)
arr = rng.Value2 'place the range in an array for faster iteration
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) Then
dict.Add arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3), vbNullString
Else
addRange_ rngRed, rng.rows(i)
End If
Next i
If Not rngRed Is Nothing Then rngRed.Interior.Color = vbRed
End Sub
Sub addRange_(rngU As Range, rngAdd As Range)
If rngU Is Nothing Then
Set rngU = rngAdd
Else
Set rngU = Application.Union(rngU, rngAdd)
End If
End Sub
Coloring a row at a time is much slower, that's why previously placing them in a Union range and color all the range at once, at the end, is much faster.
If the Union range can be huge (more than 2000 areas, or even more...), the Union range building will start slowing the code. In such a case I can supply a different code able to let the code running fast, even for such cases
If necessary, the above code can be easily adapted to color the initial row, too...

How to use activecell row and column in VBA function with filldown?

I wrote a function which will concatenate all the cells to the left of the cell the function is in, using a delimiter. My code is:
Public Function Concat_To_Left(delim As String)
Dim C, R As Long
Dim S As String
Dim Cell As Range
Set Cell = ActiveCell
C = Cell.Column
R = Cell.Row
S = Cells(R, 1).Value
For i = 2 To (C - 1)
S = S & delim & Cells(R, i).Value
Next i
Concat_To_Left = S
End Function
This code works if calculating a single row. The problem I'm running into is that the cell.row and cell.column seem to be saved from the first cell when I fill the function to the bottom of a column (by double clicking the bottom right of the cell in the excel sheet). This results in all cells with this function having the same value as the cell being filled down from.
Screen-Updating, Events, and Alerts are all on/true. Application.Calculation is set to xlCalculationAutomatic
Can anyone tell me how to make this function work on each cell the formula is filled down into, using the proper row and column for each cell (not that column matters when filling down)?
Scott's comment about using TEXT join worked as a workaround to what I was trying to accomplish.
=TEXTJOIN(", ",TRUE,B2:INDEX(2:2,COLUMN()-1))
The link he provided to the custom code for TEXTJOIN was very nice as well:
MS Excel - Concat with a delimiter
Adding Application.Volatile did not make my function work. I did not find a way to get my function working with fill down without needing a range parameter, so TEXTJOIN is the next best option and answers my question for now.
EDIT:
I wrote this macro to work instead of a function:
Private Sub Concat_To_Left()
Dim C, R, LR As Long
Dim Cell As Range
LR = ActiveWorkbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
C = ActiveCell.Column
R = ActiveCell.Row
For Each Cell In ActiveWorkbook.ActiveSheet.Range(Cells(R, C), Cells(LR, C))
Cell.Value = Cells(Cell.Row, 1).Value
For i = 2 To (C - 1)
Cell.Value = Cell.Value & "|" & Cells(Cell.Row, i).Value
Next i
Next Cell
End Sub
This one uses "|" as a delimiter, fills down from the active cell to lastrow concatenating every cell to the left, including blanks.

How to select mutiple values from excel single cell

I have excel cell having multiple rows of data with image url.
Now I want to select all images having 1500 value. So basically I want to select row starting with http and ending 1500.jpg.
Please not that in my single cell values are also other than 1500.jpg.Sample data is given below
colorImages': { 'initial': [{"hiRes":"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UL1500_.jpg","variant":"MAIN","lowRes":null},{"hiRes":"https://images-na.ssl-images-amazon.com/images/I/716mECZ9JDL._UL1500_.jpg","thumb":"https://images-na.ssl-images-amazon.com/images/I/313QD20m4WL._SR38,50_.jpg","large""thumb":"https://images-na.ssl-images-amazon.com/images/I/313QD20m4WL._SR38,50_.jpg","large":"https://images-na.ssl-images-amazon.com/images/I/313QD20m4WL.jpg","main":{"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY445_.jpg":[445,117],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY500_.jpg":[500,132],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY550_.jpg":[550,145],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY606_.jpg":[606,160],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY679_.jpg":[679,179],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY741_.jpg":[741,195],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY879_.jpg":[879,231]},
Assuming data is in Column A starting from Cell A2 and all the URLs ending with 1500.jpg needs to be displayed in adjacent columns i.e. same row Column B, Column C, Column D,.... then following might help.
Sub Demo()
Dim ws As Worksheet
Dim lastRow As Long, colIndex As Long
Dim rng As Range, cel
Dim X As Long, DotCount As Long
Dim Pat As String, EndPat As String, Parts() As String
Set ws = ThisWorkbook.Worksheets("Sheet3") 'change Sheet3 to your data sheet
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'get last row with data in Column A
For Each cel In .Range(.Cells(2, 1), .Cells(lastRow, 1)) 'loop through A2 to last cell with data in Column A
colIndex = 1
Pat = "*[!&-;?-[_a-z~=!" & Chr$(1) & "]."
EndPat = "[!&-;?-[_a-z~=!" & Chr$(1) & "]*"
Parts = Split(cel.Value, """") 'split cell value into an array
For X = 0 To UBound(Parts)
If Parts(X) Like "*?.?*" Then
DotCount = Len(Parts(X)) - Len(Replace(Parts(X), ".", ""))
If """" & Replace(Parts(X), "]", Chr$(1)) & """" Like Application.Rept(Pat, DotCount) & EndPat Then
Parts(X) = ""
ElseIf Right(Parts(X), 8) <> "1500.jpg" Then
Parts(X) = ""
Else
cel.Offset(0, colIndex) = Parts(X) 'display URL
colIndex = colIndex + 1
End If
Else
Parts(X) = ""
End If
Next X
Next cel
End With
End Sub
Derived this solution using Function URLs from here.
This is done easily via VBA, but am not expert in that. So I have done some thing for you,just follow the instruction , still it is apply to get only single search entry i.e. means in a cell its find only one 1500.jpg entry.
To get second entry in the same cell you need some effort via change or get substring from the G1 Cell string and repeat the step as explained again.
In A1 Cell, put 1500.jpg
In B1 Cell, put your actual string as you have above
In C1 cell, put formula "=SEARCH(A1,B1)", which find the search 1500 in string
In D1 cell, put formula "=MID(B1,1,C1)", which extract the substring
For E1 we need reverse the string via VBA code - Add Reversestr function (To add this function, see this link)
In F1 cell, put formula "=SEARCH(CHAR(34),E1)", which search " in above reverse string
In G1 cell, put formula "=MID(B1,C1-F1+1,C1)"
Finally you get the string in G1 Cell as "https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._1500.jpg"
For VBa formula, check this links
http://analystcave.com/excel-substring-vba-substring/

Changing the sign of numeric values in a column

I have data in column D.
There is a header in column D1 and numeric values in D2 downward. I would like to select all numeric values in column D (the number of values is unknown) and multiply them by -1 (replacing the current values in column D). How would I do this through VBA code?
If I could use formulas in Excel I would simply drag the formula D2*-1 downward; however, I need the VBA equivalent.
The following works almost instantaneously when tested with 100,000 random values:
Sub MultColDbyOne()
Dim i As Long, n As Long, A As Variant
n = Cells(Rows.Count, "D").End(xlUp).Row
A = Range(Cells(2, "D"), Cells(n, "D")).Value
For i = LBound(A) To UBound(A)
A(i, 1) = -A(i, 1)
Next i
Range(Cells(2, "D"), Cells(n, "D")).Value = A
End Sub
The sub works by first determining the last row with data in column D, then transferring it to a VBA array (which is, somewhat annoyingly, a 2-dimensional array with only 1 column), looping through that array replacing each number in it by its negative, then transferring it back. This Range to array then back to Range strategy is fairly common (and fairly efficient) in VBA.
Just for curiosity I wanted to employ selecting special cells (numbers) feature of Excel. I created another function and tested the speed against the function created by #John Coleman.
If column D contains 10,000 values, #John Coleman's function is faster.
If column D contains 1,000,000 values, this function is faster.
Sub ChangeSignColD()
Dim v, x As String
Application.ScreenUpdating = 0
x = Selection.Address
With Cells(1, 5)
v = .Value
.Value = -1
.Copy
Columns("D:D").SpecialCells(2, 1).PasteSpecial -4163, 4
.Value = v
End With
Range(x).Select
Application.CutCopyMode = 0
End Sub
In addition, I noticed that this function would not error if there was e.g. some text value in the column.
I like how #Zygd solve it, but i propose to use a cell for the -1 not interfering with existing working range.
Sub InvertNumericSign()
Dim LastCell As Range
Dim SignRng As Range
Set LastCell = Cells.SpecialCells(xlCellTypeLastCell)
Set SignRng = Selection
If Not LastCell = "" Then Set LastCell = LastCell(2, 2)
LastCell = -1
LastCell.Copy
SignRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
LastCell.ClearContents
End Sub

How to run an equation along whole column in excel vba

I want to run an excel vba which will go down column E and upon finding the value = "capa" will go two cell below, calculate the hex2dec value of that cell, present it by the cell with the value "capa" in column F and continue to search down column E.
So far I've came with the below but it doesn't work:
For Each cell In Range("E:E")
If cell.Value = "Capa" Then
ActiveCell.Offset.FormulaR1C1 = "=HEX2DEC(R[2]C[-1])"
End If
Next cell
Thanks!
How about something like this?
This will search volumn E for "Capa" and, if found, will place formula in column F using the value directly below "Capa" in column E
Sub CapaSearch()
Dim cl As Range
For Each cl In Range("E:E")
If cl.Value = "Capa" Then
cl.Offset(0, 1).Formula = "=HEX2DEC(" & cl.Offset(1, 0) & ")"
End If
Next cl
End Sub
You really want to limit the loop so you don't loop over the whole sheet (1,000,000+ rows in Excel 2007+)
Also, copying the source data to a variant array will speed things up too.
Try this
Sub Demo()
Dim dat As Variant
Dim i As Long
With ActiveSheet.UsedRange
dat = .Value
For i = 1 To UBound(dat, 1)
If dat(i, 6 - .Column) = "Capa" Then
.Cells(i, 7 - .Column).FormulaR1C1 = "=HEX2DEC(R[2]C[-1])"
End If
Next
End With
End Sub

Resources