Basically I just found this little code on the web, I thought it might help me because I want to improve it. But on the
Do Until Range("A" & amp, R) = ""
line I got the mentioned error in the title.
Here is the code:
Sub Use_Instr()
R = 1
'loop to the last row
Do Until Range("A" & amp, R) = ""
'check each cell if contains 'apple' then..
'..place 'Contains Apple' on column B
If Range("A" & amp, R) Like "*apple*" Then
Range("B" & amp, R) = "Contains Apple"
End If
R = R + 1
Loop
End Sub
It does search the "apple" term in the sentences in A column and write "contains apple" in the B
column if it contains "apple"
Try this instead:
R = 1
'loop to the last row
Do Until Range("A" & R).Value = ""
'check each cell if contains 'apple' then..
'..place 'Contains Apple' on column B
If Range("A" & R).Value Like "*apple*" Then
Range("B" & R).Value = "Contains Apple"
End If
R = R + 1
Loop
Range("A" & amp, R) is not the right way to address the range. When you copied from the website, it copied the html encoding as well. In Html & is encoded as &. Simply replace & amp, with & in your code. So your code becomes
R = 1
'loop to the last row
Do Until Range("A" & R) = ""
'check each cell if contains 'apple' then..
'..place 'Contains Apple' on column B
If Range("A" & R) Like "*apple*" Then
Range("B" & R) = "Contains Apple"
End If
R = R + 1
Loop
Also to make the code case insensitive, as suggested by #VBasic2008 in comments below, you may want to change Range("A" & R) Like "*apple*" to If LCase(Range("A" & R).Value2) Like "*apple*" Then.
Having said that, I would use a different approach than using a loop which is a slightly slower approach.
It does search the "apple" term in the sentences in A column and write "contains apple" in the B column if it contains "apple"
If you were to do this in Excel, then you would use the formula =IF(ISNUMBER(SEARCH("apple",A1)),"Contains Apple","")
So what we will do is find the last row in Column B and then add this formula in the entire range in one go! Finally we will convert the formula to values.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim sFormula As String
'~~> Change this to the relevant sheet
Set ws = Sheet1
'~~> This is your formula
' =IF(ISNUMBER(SEARCH("apple",A1)),"Contains Apple","")
sFormula = "=IF(ISNUMBER(SEARCH(""apple"",A1)),""Contains Apple"","""")"
With ws
'~~> Find the last row in column B
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Insert the formula in the entire range in 1 go
With .Range("B1:B" & lRow)
.Formula = sFormula
'~~> Convert formula to value
.Value = .Value
End With
End With
End Sub
Related
I want to apply an Formula into an entire Row (A)
My code:
Sub row()
Dim i As Long
Dim S1 As String
Dim S2 As String
S1 = "=+LINKS(C"
S2 = ";1)"
i = 2
Range("A1").EntireColumn.Insert
For i = 2 To 90000
Range("A" & i).Value = "=+Left(C "" & i & "" ;1)"
Next i
End Sub
The error is occuring on: Range("A" & i).Value = "=+Left(C "" & i & "" ;1)"
Error code: '1004'
i can't find a way to put the variable "i" into the Formula...
I want to put into the column "A" the Formula, which lets the Cells in "A" look into the Cell "C" of each individual row and take the first Number and write it in itself.
Thank you in advance.
I've been asked to create a macro that compare two numbers in two cells and then it should write a third column that says for example: L6 is less than M6 (any image of a down arrow)
I tried to record this macro:
Sub Macro20()
Range("N2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-2]=RC[-1],""L and M are equal"",IF(RC[-2]>RC[-1],""L is greater than M (UP ARROW) "",""L is less than M (DOWN ARROW)""))"
Range("N2").Select
Selection.AutoFill Destination:=Range("N2:N" & Range("L" & Rows.Count).End(xlUp).Row)
Range(Selection, Selection.End(xlDown)).Select
End Sub
and this is the output:
This is just an example, the whole code should be used to a large amount of data soon, anyway there are some errors must be avoided.
The code into the cell must not be shown (see the blue arrow into the picture), it should display only the value.
How can I fetch an arrow image instead of the string: L is greater than M (UP ARROW)?
Can you help me in doing a better code than this?
Here is a simple solution which enters the formula in the entire range without looping.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find last row in column L
lRow = .Range("L" & .Rows.Count).End(xlUp).Row
'~~> Insert the formula in Col N. Change as applicable
With .Range("N1:N" & lRow)
.Formula = "=IF(L1=M1,""L and M are equal"",IF(L1>M1,""L is greater than M " & _
ChrW(&H2191) & _
""", ""L is less than M " & _
ChrW(&H2193) & _
"""))"
'~~> Optional - Convert formula to values
.Value = .Value
End With
End With
End Sub
Screenshot
Note:
To insert Up arrow, you can use ChrW(&H2191) and for down arrow you can use ChrW(&H2193)
If you want to put the formula from the 2nd row then it will be
'~~> Insert the formula in Col N. Change as applicable
With .Range("N2:N" & lRow)
.Formula = "=IF(L2=M2,""L and M are equal"",IF(L2>M2,""L is greater than M " & _
ChrW(&H2191) & _
""", ""L is less than M " & _
ChrW(&H2193) & _
"""))"
'~~> Optional - Convert formula to values
.Value = .Value
End With
Similarly for a different row, you will have to adjust accordingly.
EDIT
do you think is possible to use a arrow text already formatted? For example a red one (or whatever color) with a specific size? And then put this inside your vba code? – Alex D. 4 hours ago
Yes it is possible. In this case you can use Worksheet_Change event to handle changes in column L and column M to populate column N
I have commented the code below. If you still have problems understanding it then feel free to ask. The below code goes in the sheet code area. You can change the symbol attributes (Style, Color and Size) right at the top of the code.
Code
Option Explicit
'~~> Change the symbol attributes here
Const Font_Style As String = "Bold"
Const Font_Size As Long = 15
Const Font_Color As Long = -16776961 '(Red)
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
Dim r As Variant
'~~> Check if the change happened in the relevant column
If Not Intersect(Target, Me.Range("L:M")) Is Nothing Then
For Each r In Target.Rows
'~~> If even one cell is empty then clear out N cell
If Len(Trim(Range("L" & r.Row).Value2)) = 0 Or _
Len(Trim(Range("M" & r.Row).Value2)) = 0 Then
Range("N" & r.Row).ClearContents
'~~> Check if L = M
ElseIf Range("L" & r.Row) = Range("M" & r.Row) Then
Range("N" & r.Row).Value = "L and M are equal"
'~~> Check if L > M
ElseIf Range("L" & r.Row) > Range("M" & r.Row) Then
With Range("N" & r.Row)
.Value = "L is greater than M " & ChrW(&H2191)
'~~> Format the symbol which is at 21st position
With .Characters(Start:=21, Length:=1).Font
.FontStyle = Font_Style
.Size = Font_Size
.Color = Font_Color
End With
End With
'~~> L < M
Else
With Range("N" & r.Row)
.Value = "L is less than M " & ChrW(&H2193)
'~~> Format the symbol which is at 18th position
With .Characters(Start:=18, Length:=1).Font
.FontStyle = Font_Style
.Size = Font_Size
.Color = Font_Color
End With
End With
End If
Next r
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
In action
Here is an alternative:
Sub alex()
Dim i As Long, LastRow As Long
Dim L, M, txt As String
LastRow = Cells(Rows.Count, "L").End(xlUp).Row
For i = 2 To LastRow
L = Cells(i, "L").Value
M = Cells(i, "M").Value
If L = M Then
txt = "they are equal"
ElseIf L > M Then
txt = "L is greater"
Else
txt = "M is greater"
End If
Cells(i, "N") = txt
Next i
End Sub
You can speed this up a little by bring all the column L and M data into VBA arrays and doing the comparisons within VBA.
To get arrows rather than text, use:
Sub alex()
Dim i As Long, LastRow As Long
Dim L, M, txt As String
LastRow = Cells(Rows.Count, "L").End(xlUp).Row
For i = 2 To LastRow
L = Cells(i, "L").Value
M = Cells(i, "M").Value
If L = M Then
txt = "n"
ElseIf L > M Then
txt = "h"
Else
txt = "i"
End If
Cells(i, "N") = txt
Next i
End Sub
and format the results cells in column N to use the Wingdings 3 font
In Column A of Sheet 1, I have a list of serial numbers which contain duplicates. I want to delete all duplicates and instead come up with a history column which captures all the information of the adjacent cells with regards to that serial number. The logic of my script goes like this: 1) Filter all distinct serial numbers into a new sheet 2) For each cell in new sheet, find all matching cells in sheet 1 3) If they match then copy adjacent columns information and create an new column with new matching information 4) The more serial duplicates are, the bigger the "history" cell of that serial number is going to have
Here is a screenshot of what I'm trying to do:
https://imgur.com/a/KEn0RIP
When I use "FindPN.Interior.ColorIndex = 3", the program does fine, finding all the 1's in the column and coloring them red. I just want to copy each the 3 cells' values that are adjacent to each '1' in Column A. I have used a Dictionary to create a dynamic variable to spit out the final cell that I want, but when I run the program, I am having problems understanding how the place the variables in the FindNext loop to spit out each different B2, C2, and D2.
Sub FindPN1() 'simplified script finding all the 1's in Sheet 1
Dim I, J, K, L, Atotal As Integer
Dim FindPN, FoundPN As Range
Dim UniqueValue As Range
Dim strStatus, strDate, strComments As Object
Atotal = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
With Sheets(1)
For I = 2 To Atotal
Set FindPN = Sheets(1).Columns(1).Find(1, LookIn:=xlValues)
If Not FindPN Is Nothing Then
Set FoundPN = FindPN
Set strStatus = CreateObject("Scripting.Dictionary")
For J = 1 To Atotal
strStatus(J) = Range("B" & I).Value
Next
Set strComments = CreateObject("Scripting.Dictionary")
For K = 1 To Atotal
strComments(K) = Range("C" & I).Value
Next
Set strDate = CreateObject("Scripting.Dictionary")
For L = 1 To Atotal
strDate(L) = Range("D" & I).Value
Next
Range("A15").Value = strDate(1)
'FindPN.Interior.ColorIndex = 3
Do
Set FindPN = .Columns(1).FindNext(After:=FindPN)
If Not FindPN Is Nothing Then
strStatus(J) = Range("B" & I).Value
strComments(K) = Range("C" & I).Value
strDate(L) = Range("D" & I).Value
'FindPN.Interior.ColorIndex = 3
Range("B15").Value = strDate(3)
If FindPN.Address = FoundPN.Address Then Exit Do
Else
Exit Do
End If
Loop
End If
Next
End With
The problem I am having is not knowing how to store my variables and having them spit out the 'History' Cell the way that I want. I have been practicing by going inside the loop to see where each variable gets defined but it seems like the strDate is always spitting out the date corresponding to the first 1.
You can make this much simpler - use a single dictionary and loop over the rows.
Add new Id's (and their "history" value) where they don't exist: if an id is already in the dictionary then append the new piece of history to the existing value.
When done, loop over the dictionary and write out the keys and the values.
Sub CombineRows()
Dim i As Long, h, k, lastRow As Long
Dim dict As Object, wsSrc As Worksheet
Set wsSrc = Sheets(1)
lastRow = wsSrc.Range("A" & Rows.Count).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRow
With Sheets(1).Rows(i)
k = .Cells(1).Value
h = .Cells(2).Value & "|" & _
.Cells(4).Text & "|" & _
.Cells(3).Value
If dict.exists(k) Then
dict(k) = dict(k) & vbLf & h
Else
dict.Add k, h
End If
End With
Next i
DumpDict dict, Sheets(2).Range("A1")
End Sub
'write out dictionary content starting at "rng"
Sub DumpDict(dict As Object, rng As Range)
Dim c As Range, k
Set c = rng.Cells(1)
For Each k In dict.keys
c.Value = k
c.Offset(0, 1).Value = dict(k)
Set c = c.Offset(1, 0)
Next k
End Sub
I am trying to clean an excel dataset provided to me using VBA in the most efficient way possible. I want to compare row values (# may vary) of 3 columns within a worksheet range, if the row values are the same for all 3 columns, then i want the values of the same rows but different columns copied into one cell.
Sample Set: red should be copied into one cell:
Expectation with black removed and red in one cell
Ultimate Want
Before/ After Expectation
In the future, SO questions should be about specific issues you are having, not a general question.
Here is a VBA function that will:
Go through each cell, until it finds an empty cell. We will assume once an empty cell is found we are at the end of your data set.
Check if any of the first three columns have changed their data from the previous cell. If they have, this is our new 'working row'. The row where we will consolidate your dataset into.
For each row, add its value from the data set column to the 'working row', unless it already exists in that row.
Once finished, go back and delete empty cells.
Here's the subroutine:
Sub clean_dataset()
Dim sh As Worksheet
Dim rw As Range
Dim workingRow As Integer
Dim col1Value As String
Dim col2Value As String
Dim col3Value As String
Dim rowCount As Integer
workingRow = 1
'Iterate through all rows on the sheet. Stop if we get to an empty row.
Set sh = ActiveSheet
For Each rw In sh.Rows
' Exit if we get to an emptry row.
If sh.Cells(rw.Row, 1).Value = "" Then
Exit For
End If
' Check if our three columns to watch have changed value. If they have, we should be in a new 'working row'
If rw.Row > 1 Then
If (Range("A" & rw.Row).Value <> Range("A" & rw.Row - 1).Value) Or (Range("B" & rw.Row).Value <> Range("B" & rw.Row - 1).Value) Or (Range("C" & rw.Row).Value <> Range("C" & rw.Row - 1).Value) Then
workingRow = rw.Row
End If
End If
' Get the values in the current row from the dataset we are trying to consolidate.
col1Value = Range("D" & rw.Row).Value
col2Value = Range("E" & rw.Row).Value
col3Value = Range("F" & rw.Row).Value
' Add the values to the working row cells, if they do not already exist
If InStr(Range("D" & workingRow).Value, col1Value) = 0 Then
Range("D" & workingRow) = Range("D" & workingRow).Value & vbLf & col1Value
End If
If InStr(Range("E" & workingRow).Value, col2Value) = 0 Then
Range("E" & workingRow) = Range("E" & workingRow).Value & vbLf & col2Value
End If
If InStr(Range("F" & workingRow).Value, col3Value) = 0 Then
Range("F" & workingRow) = Range("F" & workingRow).Value & vbLf & col3Value
End If
' As long as we are not in the working row, delete the values
If rw.Row <> workingRow Then
Range("D" & rw.Row) = vbNullString
Range("E" & rw.Row) = vbNullString
Range("F" & rw.Row) = vbNullString
End If
rowCount = rw.Row
Next rw
' End of for each
' Go back through, and delete any rows that do not have values in column D
For iter = rowCount To 1 Step -1
' If all three columns are blank, delete the row.
If Range("D" & iter).Value = vbNullString Then
sh.Rows(iter).Delete
End If
Next
End Sub
Hope this helps.
After quite a bit of searching I was able to finally find this very applicable post as my issue is similar to the OP.
I'm working with three sheets where Sheet 1 is the source, Sheet 2 is a check sheet and Sheet 3 is where I would be pasting/cleaning up my data from Sheet 2.
In Sheet1, I copy the value in Col C and filter it in Sheet2 - Col C and for each company in Col J, I need to check the volume in Col K and if volume is >/= 1, the row needs to be copy/pasted into Sheet 3 while consolidating the corresponding unique values in each cell of the row and removing duplicates and summing the values in col K. The third sheet is the expected sheet. Thanks for your help if possible.
I have two columns A and B in same excel sheet. I am trying that if in Column B two values matches then it should copy related value A in same row.
For e.g
Table
Column A Column B
xyz 1
abc 1
pqr 1
eee 2
qqq 3
www 4
oop 5
Desierd Output
column A Column B
xyz,abc,pqr 1
eee 2
qqq 3
www 4
oop 5
You could probably use a User Defined Function (aka UDF) for this. Put this into a module sheet.
Public Function conditional_concat_strs(rSTRs As Range, rCRITs As Range, rCRIT As Range, Optional sDELIM As String = ", ")
Dim c As Long, sTMP As String
Set rSTRs = rSTRs.Cells(1, 1).Resize(rCRITs.Rows.Count, rCRITs.Columns.Count)
For c = 1 To rCRITs.Cells.Count
If rCRITs(c).Value2 = rCRIT Then _
sTMP = sTMP & rSTRs(c).Value & sDELIM
Next c
conditional_concat_strs = Left(sTMP, Application.Max(Len(sTMP) - Len(sDELIM), 0))
End Function
Use like any native worksheet function.
You can also use this one:
Public Sub combine()
Dim row, result, lastRow As Integer
Dim isExist As Boolean
With Sheets("sheetname")
'get the last use row
lastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).row
'Loop from row 1 to last row
For row = 1 To lastRow Step 1
'set the start row for result.
result = 1
'Reset flag
isExist = False
'Loop result count column until blank
Do While .Range("F" & result) <> ""
'check count
If .Range("B" & row) = .Range("F" & result) Then
isExist = True
'If old, combine
.Range("E" & result) = .Range("E" & result) & "," & .Range("A" & row)
Exit Do
End If
'increase row
result = result + 1
Loop
'If new, add new record
If Not isExist Then
.Range("E" & result) = .Range("A" & row)
.Range("F" & result) = .Range("B" & row)
End If
Next row
End With
End Sub
Here, testing evidence for my code:
I used column A & B as input and column E & F as output.
If there is any problem, let me know.
There's a formula solution for this as well (with helper columns):
Assuming data is column A:B ...
In C1 write this formula: =IF(A1<>A2,B2,D1&","&B2)
In D1 write this formula: =IF(A2<>A3,A2,"")
Filter on column D for blanks and then deleted the visible cells.