I have a problem that I hope you can help me with.
The below code adds 1 day to todays day in Column B if it finds a repeated value in column A. However I want it to add 2 days if it gets repeated again and so on.
I have tried to illustrate how the codes work in the attached picture. So what I want is cell B10 in the picture to be 20/03/2021. I need to make it automatic so it can run for any number of repeated values.
Sub Add_date2()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A65000").End(xlUp).Row
For iCntr = 2 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 2) = Date + 1
Else
Cells(iCntr, 2) = Date
End If
End If
Next
End Sub
Use Application.Countifs:
Sub Add_date2()
Dim ws As Worksheet
Set ws = ActiveSheet 'better to set the actual sheet WorkSheets("Sheet1")
With ws
Dim lastRow As Long
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Dim iCntr As Long
For iCntr = 2 To lastRow
If .Cells(iCntr, 1) <> "" Then
.Cells(iCntr, 2) = Date + Application.CountIfs(.Range(.Cells(2, 1), .Cells(iCntr, 1)), .Cells(iCntr, 1)) - 1
End If
Next
End With
End Sub
Related
I have column "A1" which list names and some names ending with totals (subtotals). I need a vba code to go through each cell, and if cell contains the word "total", clear that cell and if not move on to the next one. Do this until cell before the cell that contains grand total.
Using the code below, it only looks for totals and not cells that contains more than that "Derek Smith Total". I would also need to add do it until the cell before "Grand Total".
Sub testing101()
Dim lRow As Long
Dim iCntr As Long
lRow = 130
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 1).Value = "*total*" Then
Cells(iCntr, 1).Select
Selection.ClearContents
End If
Next
End Sub
You can use Like -
Sub testing101()
Dim lRow As Long
Dim iCntr As Long
lRow = 130
For iCntr = lRow To 1 Step -1
With Cells(iCntr, 1)
If .Value Like "*total*" Then .ClearContents
End With
Next
End Sub
Sub testing101()
Dim lRow As Long
Dim iCntr As Long
lRow = 130
For iCntr = lRow To 1 Step -1
With Cells(iCntr, 1)
If .Value Like "*total*" Then
if .Value <> "Grand Total" then.ClearContents
End If
End With
Next
End Sub
I am trying to delete entire row if duplicates are found together. If not found together I want to keep it without deleting.
For an example Column A:
Apple,
Apple,
Orange,
Orange,
Apple,
Apple,
I need to have the output as;
Apple,
Orange,
Apple,
I'm using the following code but have not achieved the desired output yet (only get Apple, Orange).
Sub FindDuplicates()
Dim LastRow, matchFoundIndex, iCntr As Long
LastRow = Cells(Rows.Count, "A").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
Cells(iCntr, 10) = "Duplicate"
End If
End If
Next
last = Cells(Rows.Count, "J").End(xlUp).Row ' check results col for values
For i = last To 2 Step -1
If (Cells(i, "J").Value) = "" Then
Else
Cells(i, "J").EntireRow.Delete ' if values then delete
End If
Next i
End Sub
Doesn't something simple like
Dim LastRow As Long
Application.screenUpdating=False
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Cells(i, 1).EntireRow.Delete
End If
Next i
Application.screenUpdating=True
solve this?
Work from the bottom up and only delete if the cell above is the same value.
dim r as long
with worksheets("sheet1")
for r = .cells(.rows.count, "A").end(xlup).row to 2 step -1
if lcase(.cells(r, "A").value2) = lcase(.cells(r - 1, "A").value2) then
.rows(r).entirerow.delete
end if
next r
end with
If you do not want the comparison to be case-insensitive then remove the lcase functions.
I have found the code
Sub Test()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows,SearchDirection:=xlPrevious).Row
Dim lColumn As Long
Dim x As Long
Dim rng As Range
For Each rng In Range("A1:A" & LastRow)
lColumn = Cells(rng.Row, Columns.Count).End(xlToLeft).Column
For x = 1 To lColumn - 2
Range(Cells(rng.Row, "A"), Cells(rng.Row, "B")).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rng.Offset(0, x + 1)
Next x
Next rng
Application.ScreenUpdating = True
End Sub
I am trying to modify it to suit my needs but it isn't quite doing what I need it to do.
Basically, my table is like this:
A B C D
FILENAME ID FIELD1 FIELD2
1 2 3 4
and I want it to look like this:
A FILENAME 1
B ID 2
C FIELD1 3
D FIELD2 4
however, sometimes there may be more columns or rows associated with a given part of the range that is related to a set of data. right now the columns that
I don't know nearly enough about excel and vba to modify this code to do that, but it would be nice if I could.
below are a couple of links that explain closely how I want the final table to look.
http://pastebin.com/1i5MqTL7
http://imgur.com/a/PKAcy
The ID's are not unique product pointers, but that's the REAL world. Different considerations and assumptions about the consistency of your input data, but try this:
Private Sub TransposeBits()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'start will be the starting row of each set
Dim start As Long
start = 2
'finish will be the last row of each set
Dim finish As Long
finish = start
Dim lastRow As Long
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'printRow will keep track of where to paste-transpose each set
Dim printRow As Long
printRow = lastRow + 2
'lastCol will measure the column count of each set
Dim lastCol As Long
'Just dealing with a single entry here - delete as necessary
If lastRow < 3 Then
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
'in the trivial case, we can exit the sub after dealing with the one-line transpose
Exit Sub
End If
'more general case
For i = 3 To lastRow
If Not Range("A" & i).Value = Range("A" & i - 1).Value Then
'the value is different than above, so set the finish to the above row
finish = i - 1
lastCol = Cells(start, 1).End(xlToRight).Column
'copy the range from start row to finish row and paste-transpose
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
'after finding the end of a set, reset the start and printRow variable
start = i
printRow = printRow + lastCol
End If
Next i
'here we deal with the last set after running through the loop
finish = lastRow
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
End Sub
You can use the Paste Special that #Jeeped uses - just write it in code:
Sub TransposeData()
Dim rLastCell As Range
With ThisWorkbook.Worksheets("Sheet1")
'NB: If the sheet is empty this will throw an error.
Set rLastCell = .Cells.Find("*", SearchDirection:=xlPrevious)
'Copy everything from A1 to the last cell.
.Range(.Cells(1, 1), rLastCell).Copy
'Paste/Transpose in column A, one row below last row containing data.
.Cells(rLastCell.Row + 1, 1).PasteSpecial Transpose:=True
End With
End Sub
I have an excel document that I use to analyze data sets each data asset I bring in has varying amounts of data. I have tried to write a macro that I assign to a button that can identify delete rows based on the value of a cell. It does not work. What am I doing wrong?
Sub Button2_Click()
[vb]
'This will find how many rows there are
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox lastRow
End With
Sub sbDelete_Rows_Based_On_Criteria()
Dim lRow As Long
Dim iCntr As Long
lRow = lastRow
For iCntr = lRow To 1 Step -1
'Replaces XX with the variable you want to delete
If Cells(iCntr, 1) = "#N/A" Then
Rows(iCntr).Delete
End If
Next
End Sub
[/vb]
End Sub
Your logic is pretty much there, but your syntax is off. Additionally, you are only checking column A for the value and not column B (per your comments above).
Sub Button2_Click()
Dim lRow As Long
'This will find how many rows there are
With ActiveSheet
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox lastRow
End With
Dim iCntr As Long
For iCntr = lRow To 1 Step -1
'Replace "#N/A" with the value you want to delete
' Check column A and B for the value.
If Cells(iCntr, 1).Text = "#N/A" Or Cells(iCntr, 2).Text = "#N/A" Then
Rows(iCntr).Delete
End If
Next
End Sub
Or simplified:
Sub Button2_Click()
Dim iCntr As Long
For iCntr = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
'Replace "#N/A" with the value you want to delete
' Check column A and B for the value.
If Cells(iCntr, 1).Text = "#N/A" Or Cells(iCntr, 2).Text = "#N/A" Then
Rows(iCntr).Delete
End If
Next
End Sub
Because you have two subs, you must pass lastRow from one to the other:
Sub Button2_Click()
'This will find how many rows there are
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox lastRow
End With
Call sbDelete_Rows_Based_On_Criteria(lastRow)
End Sub
Sub sbDelete_Rows_Based_On_Criteria(lastRow)
Dim lRow As Long
Dim iCntr As Long
lRow = lastRow
For iCntr = lRow To 1 Step -1
'Replaces XX with the variable you want to delete
If Cells(iCntr, 1).Text = "#N/A" Then
Rows(iCntr).Delete
End If
Next
End Sub
Note:
the sub are unnested
Use .Text
I am trying to insert one row when the cell is column 4 doesn't have the same value. For some reason it is inserting 4 rows. It only happens at the start. What could be wrong?
Thanks for your help!
If Cells(j, 4) <> Cells(j - 1, 4) Then
Cells(j, 1).EntireRow.Insert
j = j + 1
End If
Is this what you are trying?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
For i = lRow To 2 Step -1
If .Cells(i, 4) <> Cells(i - 1, 4) Then .Cells(i, 1).EntireRow.Insert
Next i
End With
End Sub
ScreenShot: