Add comment to cell if cell in other column contains value - excel

I have a code that combines the cell contents of all cells in column C:F and puts that into a comment on column B - per row.
I now need to apply that only to rows that have content in their respective column A.
Cell A2 has something in it, so put the contents of C2:F2 into the comment of B2.
Cell A3 has nothing in it, so don't add a comment to that cell.
Cell A4 has something in it again, so put the contents of C4:F4 into the comment of B4.
The table looks something like this: Table
My code so far looks like this:
Sub Test()
Dim LRow As Integer
With ActiveSheet
For LRow = 2 To Range("A" & Rows.Count).End(xlUp).Row
Range(Cells(LRow, 3), Cells(LRow, 6)).Select
Dim c As Range, s As String
With Cells(LRow, 2)
.ClearComments
For Each c In Selection
'If c.Offset(0, -2) <> "" Then
'On Error Resume Next
If c <> "" Then s = IIf(s = "", c, s & Chr(10) & c)
Next c
.AddCommentThreaded "Test:" & Chr(10) & s
End With
s = ""
Next LRow
End With
End Sub
Problem now being that I can't get the content check in column A to work. Anyone have any hints on how to get that bit to work?

Try something like below. Also checkout how to avoid select and why use long instead of integer
Sub Test()
Dim LRow As Long, aCell As Range, ws As Worksheet
Set ws = ActiveSheet
With ws
For LRow = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(LRow, 1).Value <> "" Then
Dim theComment As String
theComment = ""
For Each aCell In Intersect(Range("C:F"), .Rows(LRow)).Cells
theComment = theComment & aCell.Value
Next aCell
With .Cells(LRow, 2)
.ClearComments
.AddCommentThreaded "Test:" & Chr(10) & theComment
End With
End If
Next LRow
End With
End Sub

Related

VBA, If all rows in Col A is filled and Col B is blank(and vice versa) then copy those rows to a new sheet

I am trying to incorporate the following logic, If all rows in Col A is filled and Col B is blank(and vice versa) then copy those rows to a new sheet.
Here is what I have so far:
Sub DataValidation()
Dim rng As Range
Dim cell As Range
Set rng = Range("A:B")
For Each cell In rng
If Cel.Value = "" Then
Sheets("List").Cel.Value.EntireRow.Copy Destination:=Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next cell
End Sub
Can anyone help with this?
I need help with 1) If.Cel.Value="" , I dont think this identifies the logic for Col A filled and Col B is blank. 2) And I need help identifying these rows and copying to a new tab.
Latest code:
Sub DataValidationTwo()
Dim ws As Worksheet, lastR As Long, arr, rngCopy As Range, i As Long
Set ws = ActiveSheet
lastR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
arr = ws.Range("AU4:AV" & lastR).Value2 'place the range in an array for faster iteration/processing
For i = 4 To UBound(arr) '4 supposing that headers exist on the third row
If (arr(i, 1) <> "" And arr(i, 2) = "") Or (arr(i, 2) <> "" And arr(i, 1) = "") Then
addToRange rngCopy, ws.Range("A" & i)
End If
Next i
If Not rngCopy Is Nothing Then rngCopy.EntireRow.Copy _
Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
MsgBox "Complete"
End Sub
new code. It is only pasting row 4 to test. It should paste more of my test rows over.
Sub DataValidationTwo()
Dim ws As Worksheet, lastR As Long, arr, rngCopy As Range, i As Long
With Sheets("test")
.Rows(2 & ":" & .Rows.Count).Delete
End With
Set ws = ActiveSheet
'Set ws = Sheets("ATP List")
lastR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
arr = ws.Range("AU4:AV" & lastR).Value2 'place the range in an array for faster iteration/processing
For i = 4 To UBound(arr) '4 supposing that headers exist on the third row
If (arr(i, 1) <> "" And arr(i, 2) = "") Or (arr(i, 2) <> "" And arr(i, 1) = "") Then
addToRange rngCopy, ws.Range("A" & i)
End If
Next i
If Not rngCopy Is Nothing Then rngCopy.EntireRow.Copy _
Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
MsgBox "Complete"
End Sub
First off, your reference to cell.value has a typo, it needs to be cell.value
As for the solution, just like Bigben said, a Range.AutoFilter is probably the simplest option here without Advanced Filters.
You'll be looking for something like this
rng.AutoFilter Field:=1, Criteria1:="<>" 'This will filter by non-blanks in Column 1
rng.AutoFilter Field:=2, Criteria1:="=" 'This will filter by blanks in Column 2
When a range is filtered, if you use rng, it will still refer to the entire range including those hidden (essentially ignoring the filter). This is why you should now use rng.specialCells(xlCellTypeVisible) to now refer to the displaying range.
Mix and match filters and then use rng.specialCells(xlCellTypeVisible).Copy
Please, try the next way. It uses an array and builds a Union range, to be copied at the code end. That's why is should be much faster than iterating between all cells and copying a row at a time:
Sub DataValidation()
Dim ws As Worksheet, lastR As Long, arr, rngCopy As Range, i As Long
Set ws = ActiveSheet
lastR = ws.Range("A" & ws.rows.count).End(xlUp).row
arr = ws.Range("AU4:AV" & lastR).Value2 'place the range in an array for faster iteration/processing
For i = 2 To UBound(arr) '2 supposing that headers exist on the first row
If (arr(i, 1) <> "" And arr(i, 2) = "") Or (arr(i, 2) <> "" And arr(i, 1) = "") Then
addToRange rngCopy, ws.Range("A" & i)
End If
Next i
If Not rngCopy Is Nothing Then rngCopy.EntireRow.Copy _
Sheets("test").Range("A" & rows.count).End(xlUp).Offset(1)
End Sub
Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub

Excel VBA - Add hyphens to column A if column B contains specific letter

Please help a newbie.
Using Excel VBA, I am trying to format the text in column A with hyphens but only if column B contains the letter B.
I have found the code below, one which formats the cells in column A with hyphens, and another code which checks column B for the correct value, but cannot seem to combine them to work. Help please.
Thank you.
Sub AddDashes()
Dim Cell As Range
On Error GoTo NoFilledCells
For Each Cell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeConstants)
Cell.Value = Format(Replace(Cell.Value, "-", ""), "#####-###-####")
Next
NoFilledCells:
End Sub
and
Sub ChangeColumn()
Dim LastRow As Long
Dim i As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Range("B" & i).Value = "B" Then
Range("A" & i).Value = "Formatted text with hyphens as above"
End If
Next i
End Sub
Option Explicit
Sub AddDashes()
Dim ws As Worksheet, cell As Range
Dim LastRow As Long
Set ws = ActiveSheet
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In ws.Range("A2:A" & LastRow)
If cell.Offset(0, 1) = "B" Then ' col B
cell.Value = Format(Replace(cell.Value, "-", ""), "#####-###-####")
End If
Next
End Sub

Fill blank cells based on non blank cell above

I want to fill blank cells in sequential order based on the cell above.
The interval to be filled for column F is not consistent. Need to fill down two up to 20 rows based on the item number above.
Need VBA and not a formula.
This code would copy the item above the non blank and paste it down.
Sub FillBlanks()
Columns("F:F").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End Sub
What I need is to autofill in sequence until the next nonblank.
Something like:
OA205S061169
OA205S061170
OA205S061171
OA205S061172
OA205S061173
OA205S061174
You can select your blank cells, as you are already doing, and then loop through each area, as follows...
Sub FillBlanks()
Dim lastRow As Long
Dim dataRange As Range
Dim currentArea As Range
lastRow = Cells(Rows.Count, "F").End(xlUp).Row
On Error Resume Next
Set dataRange = Range("F1:F" & lastRow).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not dataRange Is Nothing Then
For Each currentArea In dataRange.Areas
With currentArea
With .Offset(-1, 0).Resize(.Rows.Count + 1)
.Cells(1).AutoFill Destination:=.Cells, Type:=xlFillDefault
End With
End With
Next currentArea
End If
End Sub
Note that it uses Column F to find the last used row. However, depending on your data, you'll likely need to use some other column to determine the last used row. To use Column A, for example, use the following instead...
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Try
Sub FillTest()
Dim rngDB As Range
Dim vDB, vSplit
Dim i As Long, x As Long, n As Integer
Dim s As String
Set rngDB = Range("f1", Range("f" & Rows.Count).End(xlUp))
vDB = rngDB
For i = 1 To UBound(vDB, 1)
If vDB(i, 1) <> "" Then
vSplit = Split(vDB(i, 1), "S")
s = vSplit(0) & "S"
x = vSplit(1)
n = 0
Else
n = n + 1
vDB(i, 1) = s & Format(x + n, "000000")
End If
Next i
rngDB = vDB
End Sub

Find value in Column B and copy value to new sheet

I have a workbook with multiple sheets. Each sheet always has a value in column B called "General Conditions" and the value in Column C is a dollar amount. I'm trying to find the "General Conditions" value and then copy the value in Col C to a new sheet. The values are always in Col B and C, but different row numbers.
Example:
General Conditions | 658.25
This is what I sort of had working. I would ideally want to loop through all the sheets in the workbook.
Sub macro()
For Each c In Range(Range("B1"), Range("B" & Rows.Count).End(xlUp))
If c Like "*General Conditions*" Then
c.EntireRow.Copy Sheets("Sheet1").Range("B" & Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row + 1)
End If
Next
End Sub
Try this....
Sub macro()
Dim irows As Integer
For Each ws In ActiveWorkbook.Worksheets
If ws.Range("B2").Value = "" Then
irows = 1
Else
irows = ws.Range("B1").End(xlDown).Row
End If
For Each c In ws.Range("B1:B" & irows)
If c.Value Like "*General Conditions*" And ws.Name <> "Sheet1" Then
c.EntireRow.Copy Sheets("Sheet1").Range("B" & Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row + 1).EntireRow
End If
Next c
Next ws
End Sub
try this
Sub macro()
Dim c As Range
Set c = Range("B1", Cells(Rows.count, "B").End(xlUp)).Find(what:="General Conditions", LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then c.EntireRow.Copy Sheets("Sheet1").Cells(Rows.count, "B").End(xlUp).Offset(1)
End Sub

Append cell to a different cell

I Have a Column C that has names in all its cells and another Column E that has the same company name in all its cells I need to append the names in Column C to the company name in column E
Thanks
Ex:
ColC ColE
Bob SampleCo
Sally SamplCo
I get
ColC ColE
Bob SampleCo Bob
Sally SamplCo Sally
I am trying but failing with
Sub CompanyName()
Dim LastRow As Long
Dim Ws As Worksheet
Dim rRange As range
Set rRange = range("E2")
rRange.Select
Set Ws = Sheets("WP_SubjectList_Ready")
LastRow = Ws.range("F" & Ws.Rows.Count).End(xlUp).Row
Ws.range("E2:E" & LastRow).FormulaR1C1 = "=rRange &RC[-1]"
range("E2:E" & LastRow).Copy
range("E2:E" & LastRow).PasteSpecial xlPasteValues
End Sub
Code
Sub CompanyName()
Dim LastRow As Long
Dim Ws As Worksheet
Set Ws = Sheets("WP_SubjectList_Ready")
LastRow = Ws.Range("E" & Ws.Rows.Count).End(xlUp).Row
Ws.Range("F2:F" & LastRow).FormulaR1C1 = "= RC[-1] & "" "" & RC[-3]"
End Sub
If you want the output in Column E its not possible using FormulaR1C1.
Any formula which work for excel interface will work for FormulaR1C1.
With that i mean (considering the image) in cell F2 you can manullay enter a formula = E2 & " " & C2 which will give you desired output. But if you enter in cell E2the formula as =E2 & " " & C2 the cell E2 will loose its value and this may even lead to circular reference issue.
It can be achieved using below code.
Sub CompanyName()
Dim LastRow As Long
Dim Ws As Worksheet
Dim rng As Range, cell As Range
Set Ws = Sheets("WP_SubjectList_Ready")
LastRow = Ws.Range("E" & Ws.Rows.Count).End(xlUp).Row
Set rng = Ws.Range("E2:E" & LastRow)
For Each cell In rng
cell = cell & " " & cell.Offset(0, -2)
Next
End Sub
Here's some code that should help you with what you want...I don't typically use ranges for loops because it's easier to use .Cells(row, col) for me, but anyways:
EDIT: Added Sub Opening/Closing Syntax and edited to use WS instead of ActiveSheet so it's closer to what you want
Sub CompanyName()
Dim WS as Worksheet
Dim vRow
Dim vRowCount As Integer
Set WS = Sheets("WP_SubjectList_Ready")
'Gets Row # of Last Row for Column E
vRowCount = Range("E" & Rows.Count).End(xlUp).row
'Assuming Both Columns have the same row count and you have a header row
For vRow = 2 To vRowCount
WS.Cells(vRow, 5).Value = WS.Cells(vRow, 5).Value & " " & WS.Cells(vRow, 3).Value
Next vRow
End Sub

Resources