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
Related
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
Want to find duplicates in a column in excel and want to popup a msgbox upon finding even 1 duplicate and it shouldn't keep on popping messages if it finds more than one duplicate.
Also, if i can use two column cell values and use that together to find duplicates, this would be also helpful.
Sub ColumnDuplicates()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A65000").End(xlUp).Row
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
If iCntr <> matchFoundIndex Then
MsgBox ("There are duplicates in Column A")
End If
End If
Next
MsgBox ("No Duplicates in Column A")
End Sub
Expecting to print message saying that column A has duplicates or does not have duplicates
What about the use of EVALUATE?
Public Sub Test()
With ThisWorkbook.Sheets("Sheet1")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
If .Evaluate("=Max(countif(A1:A" & lr & ",A1:A" & lr & "))") > 1 Then
MsgBox "Duplicates!"
Else
MsgBox "No Duplicates!"
End If
End With
End Sub
Or, parameterized:
Public Sub Test(ByVal sheet As Worksheet, ByVal columnHeading As String)
With sheet
lr = .Cells(.Rows.Count, columnHeading).End(xlUp).Row
If .Evaluate("=Max(countif(" & columnHeading & "1:" & columnHeading & lr & "," & columnHeading & "1:" & columnHeading & lr & "))") > 1 Then
MsgBox "Duplicates!"
Else
MsgBox "No Duplicates!"
End If
End With
End Sub
Now you can invoke it like this:
Test Sheet1, "A" ' find dupes in ThisWorkbook/Sheet1 in column A
Test Sheet2, "B" ' find dupes in ThisWorkbook/Sheet2 in column B
Test ActiveWorkbook.Worksheets("SomeSheet"), "Z" ' find dupes in "SomeSheet" worksheet of whatever workbook is currently active, in column Z
Throw your values in a dictionary
Sub ColumnDuplicates()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A65000").End(xlUp).Row
Set oDictionary = CreateObject("Scripting.Dictionary")
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
If oDictionary.Exists(Cells(iCntr, 1).Value) Then
MsgBox ("There are duplicates in Column A")
Exit Sub
Else
oDictionary.Add Cells(iCntr, 1).Value, Cells(iCntr, 1).Value
End If
End If
Next
MsgBox ("No Duplicates in Column A")
End Sub
If you have Excel 2007+ then this will be faster. This code ran in 1 sec for 200k rows
Sub Sample()
Debug.Print Now
Dim ws As Worksheet
Dim wsTemp As Worksheet
Set ws = Sheet1
Set wsTemp = ThisWorkbook.Sheets.Add
ws.Columns(1).Copy wsTemp.Columns(1)
wsTemp.Columns(1).RemoveDuplicates Columns:=1, Header:=xlNo
If Application.WorksheetFunction.CountA(ws.Columns(1)) <> _
Application.WorksheetFunction.CountA(wsTemp.Columns(1)) Then
Debug.Print "There are duplicates in Col A"
Else
Debug.Print "duplicates found in Col A"
End If
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Debug.Print Now
End Sub
I used the below code to generate 200k records in Col A
Sub GenerateSampleData()
Range("A1:A200000").Formula = "=Row()"
Range("A1:A200000").Value = Range("A1:A200000").Value
Range("A10000:A20000").Value = Range("A20000:A30000").Value
End Sub
Code execution
How to delete the values which are not followed by second immediate cell?
Following might help.
Sub Demo()
Dim ws As Worksheet
Dim lastRow As Long
Dim cel As Range
Set ws = ThisWorkbook.Sheets("Sheet5") 'change Sheet5 to your data sheet
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each cel In .Range("B1:B" & lastRow)
If IsEmpty(cel) Then 'or use If Len(cel) = 0 Then
cel.Offset(0, -1).ClearContents
End If
Next cel
End With
End Sub
If you want to delete the rows where Column B is empty then try this
Sub Demo()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet5") 'change Sheet5 to your data sheet
ws.Range("B1:B100").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'change range as per your data
End Sub
Use this macro. Enter it in regular module (eq Module 1). it will remove all values in column A in case there is no value in adjacent cell in column B.
Sub delete()
For x = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Range("B" & x).Value <> "" Then
Else
Range("A" & x).ClearContents
End If
Next x
End Sub
or if you want to delete those rows.
Sub deleteRows()
For x = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
If Range("B" & x).Value <> "" Then
Else
Range("A" & x).EntireRow.delete
End If
Next x
End Sub
I have a Sheet with columns A through F. I'm looking for the program to run through all the rows (Is there a way for it to only do active rows?) and check if D1 & E1 & F1 are blank, then hide the row (and so on).
Here's what I have which doesn't really work too well....
Sub Celltest2()
Dim rw As Range, cel As Range
Dim i As Integer
Dim celset As Range
For Each rw In Sheets("Phonelist").Range("D2:F5000").Rows
For Each cel In rw.Cells
If Len(cel.Text) = 0 Then
cel.EntireRow.Hidden = True
End If
Next
Next
End Sub
Try the code below:
Sub Celltest2()
Dim rw As Range, cel As Range
Dim i As Integer
Dim celset As Range
Dim LastRow As Long
With Sheets("Phonelist")
' find last row with data in Columns "D, "E" and "F" >> modify to your needs
LastRow = WorksheetFunction.Max(.Cells(.Rows.Count, "D").End(xlUp).Row, _
.Cells(.Rows.Count, "E").End(xlUp).Row, _
.Cells(.Rows.Count, "F").End(xlUp).Row)
For Each rw In .Range("D2:F" & LastRow).Rows
If WorksheetFunction.CountA(Range("D" & rw.Row & ":F" & rw.Row)) = 0 Then
rw.EntireRow.Hidden = True
End If
Next rw
End With
End Sub
Option 2: You can replace the loop above (the one that starts with For Each rw In .Range("D2:F" & LastRow).Rows) with the following loop:
For i = 2 To LastRow
If WorksheetFunction.CountA(Range("D" & i & ":P" & i)) = 0 Then
Rows(i).EntireRow.Hidden = True
End If
Next i
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