I have a vba code to check if a value of column 2 is duplicate and then if duplicate is found go to check on the same row but different columns if a cells is empty check if it is on weekend(Dates are listed on the first row) and if it is not go back 3 cells and highlight the cell.
I have tried using a nested loop to check first if the value is duplicate then check if the cell is empty and different from weekend
lastRow = Range("B65000").End(xlUp).row
Sheet1.Activate
For i = 2 To lastRow 'loop to run the entire condition
If Trim(Cells(i, 2)) <> "" And Trim(Cells(i, 2)) <> "-" Then
If Application.WorksheetFunction.CountIf(Range("B2:B" & lastRow), Range ("B" & i)) > 1 Then
For col = 5 To 17
If Trim(Cells(i, col)) = "" And Weekday(Cells(1, col)) <> 7 Or 1 Then
Cells(i, col - 3).Interior.Color = vbRed
End If
Next col
End If
End If
Next i
but it ends up highlighting the all the cells instead of just one cell
Related
I have rows of data
Some rows are blank apart from Column C
If Column A is blank then I would like to concatenate Column C with column C from the row above - then delete the row. There could be situations where Column A has 2 or more blank rows, so that would require all those rows in Column C to be merged together
This is the code I used, but I keep getting a mismatch error - not sure where I am going wrong, but the error highlights the line with the offsets in
Sub Merge()
Dim rng As Range
Set ws = Worksheets("test") 'Change your sheet name
Set rng = ws.Range("A1:M5600")
With ws
For i = rng.Rows.Count To 1 Step -1
If .Cells(i, 1) = "" Then
.Cells(i, 3).Offset(-1) = .Cells(i, 3).Offset(-1) & .Cells(i, 3)
.Rows(i).EntireRow.Delete
End If
Next
End With
End Sub
Maybe my comment is not very clear, this is what I mean:
If .Cells(i, 1).Value = "" Then
.Cells(i, 3).Offset(-1).Value = .Cells(i, 3).Offset(-1).Value & ", " & .Cells(i, 3).Value
(I also added ", " for readability purposes)
Edit after comment
.Cells(i, 3).Offset(-1).Value = CStr(.Cells(i, 3).Offset(-1).Value) & ", " & CStr(.Cells(i, 3).Value)
Is that better?
I am trying to compare two tables on the same excel sheet between rows. Following is what i am trying to achieve. I have worked something out, but it's not functionnal as it deletes rows...
A B C D E F
E1 40 12 4 4/16/2017 E4
E2 20 1 5 6/22/2016 E2
E1 10 0 4 6/30/2017 E1
E1 40 12 6 4/16/2017 E4
Should turn into :
A B C D E F
E1 40 12 4;6 4/16/2017 E4
E2 20 1 5 6/22/2016 E2
E1 10 0 4 6/30/2017 E1
TASK 1
If column A matches
If column B matches
If column C matches
If column F matches
Then
Concatenate rows on lines D and add a ";" between values
And delete rows that are concatenated.
I have achieved this with this code (just added the condition for F but it's not workind) , but it's not functional already without it, as it doesn't store values in a dictionnary probably and jumps rows, so it doesn't concatenate all of the values in the sheet and skips some too...
Sub TEMPLATE()
Dim lngRow As Long For lngRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1
If StrComp(Range("B" & lngRow), Range("B" & lngRow - 1), vbTextCompare) = 0 And
If StrComp(Range("A" & lngRow), Range("A" & lngRow - 1), vbTextCompare) = 0 And
If StrComp(Range("C" & lngRow), Range("C" & lngRow - 1), vbTextCompare) = 0 And
If StrComp(Range("F" & lngRow), Range("F" & lngRow - 1), vbTextCompare) = 0
Then
If Range("D" & lngRow) <> "" Then
Range("D" & lngRow - 1) = Range("D" & lngRow - 1) & ";" & Range("D" & lngRow)
End If
Rows(lngRow).Delete
End If
Next
End Sub
TASK 2
Since this is an update file, I would like to compare every rows on the old file and make changes, and highloght them, if possible. Let's say, if my E1 line up there has been added a value on B, it would highlight B case and add the value.
I don't know how to do this one, I believe it should loop between the old sheet and the updated sheet where I run the previous macro.
Thanks guys for your help !
The code below should complete your TASK 1. It assumes everything is in the first sheet. It works with your example, but I haven't tested it much further so beware. However, I think it's clear enough so you can edit it if needed.
TASK 1:
Sub filter_data()
'Initialize iterator at row 1
i = 0
'Loop through data until no more rows
Do While Sheets(1).Range("A1").Offset(i, 0).Value2 <> ""
'Get values of row
A_val_1 = Sheets(1).Range("A1").Offset(i, 0).Value2
B_val_1 = Sheets(1).Range("A1").Offset(i, 1).Value2
C_val_1 = Sheets(1).Range("A1").Offset(i, 2).Value2
D_val_1 = Sheets(1).Range("A1").Offset(i, 3).Value2
F_val_1 = Sheets(1).Range("A1").Offset(i, 5).Value2
'Loop through data again to check if duplicates
j = i 'Initialize iterator at row i
Do While Sheets(1).Range("A1").Offset(j, 0).Value2 <> ""
If j <> i Then 'Skip selected row
'Get values of row
A_val_2 = Sheets(1).Range("A1").Offset(j, 0).Value2
B_val_2 = Sheets(1).Range("A1").Offset(j, 1).Value2
C_val_2 = Sheets(1).Range("A1").Offset(j, 2).Value2
D_val_2 = Sheets(1).Range("A1").Offset(j, 3).Value2
F_val_2 = Sheets(1).Range("A1").Offset(j, 5).Value2
'If conditions satisfied
If A_val_1 = A_val_2 And B_val_1 = B_val_2 And C_val_1 = C_val_2 And F_val_1 = F_val_2 Then
'Concatenate on D
Sheets(1).Range("A1").Offset(i, 3).Value2 = Sheets(1).Range("A1").Offset(i, 3).Value2 & ";" & D_val_2
'Delete duplicate row
Sheets(1).Rows(j + 1).Delete
'Decrement incrementor by 1 to make up for deleted row
j = j - 1
End If
End If
j = j + 1 'increment
Loop
i = i + 1 'increment
Loop
End Sub
Maybe (?) I'll get back to TASK 2 later, but that should be very straightforward - you just need to loop through all cells, compare an highlight.
EDIT: Task 2 below as far as I understood it. It only checks for difference in the new sheet, highlights differences from old sheet cell-wise and appends the old value to the LEFT of the new value (can be changed). Again, it works with your example.
TASK 2:
Sub compare_data()
'Initialize sheets to compare; only cells on new sheet will be highlighted
old_sheet_idx = 1 'index of old sheet
new_sheet_idx = 2 'index of updated sheet
'Get number of populated rows & column in new sheet
new_sheet_rows = Range(Sheets(new_sheet_idx).Range("A1"), Sheets(new_sheet_idx).Range("A1").End(xlDown)).Count
new_sheet_cols = Range(Sheets(new_sheet_idx).Range("A1"), Sheets(new_sheet_idx).Range("A1").End(xlToRight)).Count
'Clear all formats in new sheet
Sheets(new_sheet_idx).Cells.ClearFormats
'Loop through all rows of new sheet
For i = 1 To new_sheet_rows
'Loop through all cells of the row
For j = 1 To new_sheet_cols
'Get cell value
new_cell = Sheets(new_sheet_idx).Range("A" & i).Offset(0, j - 1).Value2
old_cell = Sheets(old_sheet_idx).Range("A" & i).Offset(0, j - 1).Value2
'Compare
If new_cell <> old_cell Then
Sheets(new_sheet_idx).Range("A" & i).Offset(0, j - 1).Interior.ColorIndex = 6 'highlight yellow
Sheets(new_sheet_idx).Range("A" & i).Offset(0, j - 1).Value2 = old_cell & ";" & new_cell 'concatenate old value;new value
End If
Next j
Next i
End Sub
I am trying to make a loop that prints every value between two cells in a row into a single column. I would also like it to skip/ignore non integer values.
For example: Cell A5 contains 5673 and Cell B5 contains 5677. Therefore the macro would output 5673, 5674, 5675, 5676, and 5677.
I have found some useful examples for looping through each row and printing each value, but have not been able to combine the two.
To print each value between the two numbers:
[D1] = [A1].Value
ato = [B1].Value
[D1].DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=ato
To loop through every row:
LR = Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To LR
Cells(j, 1).Offset(0, 2).Value = ***Every cell value between Cells(j, 1) and Cells(j, 2)***
Next j
Before:
Desired after:
Try this. You can use SpecialCells to pick out the numerical cells, and Fill to produce the intervening sequences.
Sub x()
Dim rA As Range, rCell As Range
For Each rA In Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers).Areas
For Each rCell In rA
Range("D" & Rows.Count).End(xlUp)(2).Value = rCell.Value
Range("D" & Rows.Count).End(xlUp).DataSeries Rowcol:=xlColumns, Step:=1, Stop:=rCell.Offset(, 1), Trend:=False
Next rCell
Next rA
End Sub
If you will always have these 2 columns, then you may use this code
for j = 1 to 2:for i = 1 to cells(rows.count,j).end(xlup).row
if isnumeric(cells(i,j)) then cells(rows.count,4).end(xlup).offset(1,0) = cells(i,j)
next:next
bear in mind that it will post everysingle number, if you need to delete duplicates, you may do it using range.removeduplicate
Loop through the range cell by cell; test for IsNumeric and Duplicate values. Note: this is just a test code, you should always add workbook and worksheet references
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 2
If IsNumeric(Cells(i, j)) And Cells(i, j).Offset(, 1).Value <> Cells(i, j).Value Then
If IsEmpty(Cells(1, 4).Value) Then
Cells(1, 4) = Cells(i, j)
Else: Cells(Rows.Count, 4).End(xlUp).Offset(1) = Cells(i, j)
End If
End If
Next j
Next i
I have a sheet that I want to check the language in Column R for <> ‘Cash’; if ‘Cash’ do skip to the next row. If Column R <> ‘Cash’, check Column A for duplicate ID (there may or may not be duplicates). If duplicates are found, I want to check Column K for positive/negative values, like 100000 & -100000, then delete the entire row where the negative value appears in Column K. How can I do that?
Following the roles described above, row 6 would be deleted in the image below.
I could use VBA in Excel, or SQL/VBA in Access.
This seems to work pretty well.
Sub TryMe()
Dim i As Long
Dim j As Long
Dim ws As Worksheet
Set ws = Sheet1
For i = 2 To 13
For j = 2 To 13
If ws.Range("A" & i).Value = ws.Range("A" & j).Value Then
If ws.Range("A" & i).Offset(0, 10).Value = -(ws.Range("A" & j).Offset(0, 10).Value) Then
If ws.Range("A" & i).Offset(0, 17).Value <> "Cash" Then
Rows(i).EntireRow.Delete
End If
End If
Exit For
End If
Next j
Next i
End Sub
Could someone please help me with some code to delete all duplicate entries across multiple columns and rows. Any cell which has a duplicate value I'd like to be blank, but I do not want to delete the cell and shift all the rows up like the remove duplicates button does. I'd like code exactly like conditional formatting does to highlight cells, but I'd like to set the value to "" instead.
I'm trying to edit the macro I recorded to something like:
Columns("I:R").Select
selection.FormatConditions.AddUniqueValues
selection.FormatConditions(1).DupeUnique = xlDuplicate
selection.FormatConditions(1).Value = ""
But I'm not sure I'm on the right track
Start at the bottom and work towards the top. Take a ten-column-conditional COUNTIFS function of the cell values while shortening the rows examined by 1 every loop.
Sub clearDupes()
Dim rw As Long
With Worksheets("Sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With Intersect(.Range("I:R"), .UsedRange)
.Cells.Interior.Pattern = xlNone
For rw = .Rows.Count To 2 Step -1
With .Resize(rw, .Columns.Count) 'if clear both then remove this
If Application.CountIfs(.Columns(1), .Cells(rw, 1), .Columns(2), .Cells(rw, 2), _
.Columns(3), .Cells(rw, 3), .Columns(4), .Cells(rw, 4), _
.Columns(5), .Cells(rw, 5), .Columns(6), .Cells(rw, 6), _
.Columns(7), .Cells(rw, 7), .Columns(8), .Cells(rw, 8), _
.Columns(9), .Cells(rw, 9), .Columns(10), .Cells(rw, 10)) > 1 Then
'test with this
.Rows(rw).Cells.Interior.Color = vbRed
'clear values with this once it has been debugged
'.Rows(rw).Cells.ClearContents
End If
End With 'if clear both then remove this
Next rw
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I've left some code in that only marks the potential duplicates. When you are happy with the results, change that to the commented code that actually clear the cell contents.
Using two sets of nested loops I check each cell in the range twice, once to see if it was a duplicate and to mark it and a second time to then remove the value (ensuring I remove all duplicates and do not leave one instance of each duplicate).
I'm sure that this is an inefficient way of doing it but it works so hopefully helps someone else in the same boat.
Private Sub CommandButton1_Click()
Dim Row As Integer
Dim Column As Integer
Row = 100
Column = 10
'loop through identifying the duplicated by setting colour to blue
For i = 1 To Row 'loops each row up to row count
For j = 1 To Column 'loops every column in each cell
If Application.CountIf(Range(Cells(4, 1), Cells(Row, Column)), Cells(i, j)) > 1 Then 'check each cell against entire range to see if it occurs more than once
Cells(i, j).Interior.Color = vbBlue 'if it does sets it to blue
End If
Next j
Next i
'loop through a second time removing the values in blue (duplicate) cells
For i = 1 To Row 'loops each row up to row count
For j = 1 To Column 'loops every column in each cell
If Cells(i, j).Interior.Color = vbBlue Then 'checks if cell is blue (i.e duplicate from last time)
Cells(i, j) = "" 'sets it to blank
Cells(i, j).Interior.Color = xlNone 'changes colour back to no fill
End If
Next j
Next i
End Sub
Use conditional format to highlight duplicates and then change the value to "" using a loop through selection.
This code will allow one value to remain.(if you have 25 twice, this code will keep one 25)
Option Explicit
Sub DupRem()
Application.ScreenUpdating = False
Dim rn As Range
Dim dup As Range
Columns("I:R").FormatConditions.AddUniqueValues
Columns("I:R").FormatConditions(1).DupeUnique = xlDuplicate
Columns("I:R").FormatConditions(1).Font.Color = RGB(255, 255, 0)
For Each rn In Columns("I:R").Cells
If rn <> "" Then
If rn.DisplayFormat.Font.Color = RGB(255, 255, 0) Then
If dup Is Nothing Then
Set dup = rn
Else
Set dup = Union(dup, rn)
End If
End If
End If
Next
dup.ClearContents
Columns("I:R").FormatConditions(1).StopIfTrue = False
Columns("I:R").FormatConditions.Delete
Application.ScreenUpdating = True
End Sub