I need to compare values on two separate sheets, both are in column H starting at 2. One sheet is labeled final, the other data. If it is in final and not in data then highlight in final. If something found in data is not in final copy it into final (whole row) at the bottom. It is all text. Column H is titled "Reference".
code 1
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column <> 8 Then Exit Sub
Dim lastRow As Long
Dim rng As Range, cell As Range
lastRow = Range("H" & Rows.Count).End(xlUp).Row
If lastRow < 2 Then lastRow = 2
Set rng = Range("H2:H" & lastRow)
For Each cell In rng
With Sheets("data")
a = Application.VLookup(cell.Value, .Range("H2:H" & .Range("H" & Rows.Count).End(xlUp).Row), 1, 0)
If IsError(a) Then
cell.Interior.Color = vbYellow
Else
cell.Interior.Color = xlNone
End If
End With
Next
Application.EnableEvents = True
End Sub
code 2
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column <> 8 Then Exit Sub
Dim lastRow As Long
Dim rng As Range, cell As Range
lastRow = Range("H" & Rows.Count).End(xlUp).Row
If lastRow < 2 Then lastRow = 2
Set rng = Range("H2:H" & lastRow)
For Each cell In rng
With Sheets("final")
a = Application.VLookup(cell.Value, .Range("H2:H" & .Range("H" & Rows.Count).End(xlUp).Row), 1, 0)
If IsError(a) Then
cell.Copy .Range("H" & .Range("H" & Rows.Count).End(xlUp).Row)
End If
End With
Next
Application.EnableEvents = True
End Sub
Related
I need to merge rows with same values on excel - I tried using pivot tables, and consolidate and I could not get the desired output. I need rows with same columns merged
Try,
Sub test()
Dim rngDB As Range
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set rngDB = Range("b2", Range("b" & Rows.Count).End(xlUp))
MergeRange rngDB
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Sub MergeRange(rngDB As Range)
Dim rng As Range
Dim rngO As Range, myCell As Range
Dim n As Integer
For Each rng In rngDB
If rng <> "" Then
n = WorksheetFunction.CountIf(rngDB, rng)
Set rngO = rng.Offset(, 1).Resize(n)
MergeRange rngO
For Each myCell In rngO
If myCell <> "" Then
myCell.Resize(WorksheetFunction.CountIf(rngO, myCell)).Merge
End If
Next myCell
rng.Resize(n).Merge
End If
Next rng
End Sub
Which column are you testing to do the consolidation? Is it B or C? Anyway, try this, and adjust the code to suit your specific needs.
Sub Macro()
Dim lngRow As Long
For lngRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If StrComp(Range("B" & lngRow), Range("B" & lngRow - 1), vbTextCompare) = 0 Then
If Range("C" & lngRow) <> "" Then
Range("C" & lngRow - 1) = Range("C" & lngRow - 1) & "; " & Range("C" & lngRow)
End If
Rows(lngRow).Delete
End If
Next
End Sub
Before:
After:
I want code that adds a value of range("B6") every time it counts from Range("B1 : B5") cell that has Green Background and value = 0 while in a worksheet_Change event.
Here's my code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Set ws = ActiveSheet
lastRow = 5
For i = 2 To lastRow
With ws.Cells(i, 2)
If .Interior.ColorIndex = 4 And .Value = 0 Then
MsgBox "Test" ' <----- supposedly range("B6").value .add
End If
End With
Next
End Sub
Please, try this code:
It works only for cell changed in the range "B1:B" & lastRow. Would you like to work for any cell changed in all the sheet? I think, it could be annoying...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet, rng As Range, lastRow As Long
Dim i As Long, iCount As Long, iCountC As Long
Set ws = ActiveSheet
lastRow = 5
Set rng = ws.Range("B1:C" & lastRow)
If Not Intersect(Target, rng) Is Nothing Then
For i = 1 To lastRow
With ws.Cells(i, 2)
If .Interior.ColorIndex = 4 And .Value = 0 Then
iCount = iCount + 1
End If
If .Offset(0, 1).Interior.ColorIndex = 4 And _
.Offset(0, 1).Value = 0 Then
iCountC = iCountC + 1
End If
End With
Next
ws.Range("B" & lastRow + 1).Value = iCount
ws.Range("C" & lastRow + 1).Value = iCountC
End If
End Sub
It returns the number of green cells, immediately after the lastRow. So, if you modify this number (from 5 to 15), it will return in "B16"...
For your second request I used .Offset(0, 1) which means the neighbor cell to the right...
I have the following code (which clears the values in dependent drop downs) in the Sheet2 Code Window
Private Sub Worksheet_Change(ByVal Target As Range)
'Update by Extendoffice 2018/06/04
On Error GoTo ErrorHandler
Application.EnableEvents = False
If Target.Column = 5 And Target.Validation.Type = 3 Then
Target.Offset(0, 1).Value = ""
Target.Offset(0, 2).Value = ""
End If
If Target.Column = 6 And Target.Validation.Type = 3 Then
Target.Offset(0, 1).Value = ""
End If
Application.EnableEvents = True
ErrorHandler:
Application.EnableEvents = True
End Sub
That code worked fine until I added a Button and the following code (which copies the existing row and inserts the selection into a new row) in Module1. Now the Button Event works fine but the Change event doesn't seem to ever fire.
Sub AddRow()
Dim LastRow As Long
Dim NextRow As Long
With Sheet2
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
NextRow = LastRow + 1
With .Range("B" & LastRow & ":I" & LastRow)
Range("B" & LastRow & ":I" & LastRow).Select
Selection.Copy
Range("B" & NextRow & ":I" & NextRow).Select
Selection.Insert Shift:=xlDown
Range("C" & NextRow & ":I" & NextRow).Select
Selection.Clear
End With
End With
End Sub
Any Suggestions?
I have to generate a spreadsheet of upcoming events, and I use a macro that creates a thick line that separates each date from the one above it. It's based on the value change in the "Date" column". However, sometimes I have to filter the data by another criteria (say, the county). In those cases, the offset macro I've been using doesn't always work, as the data that changes and produces the line is in a hidden row, and therefore the line is as well. Can anyone help?
I've tried various ways of defining the range as active cells only, but I don't think I'm doing it correctly.
The macro I'm using is as follows, without applying to hidden rows:
Sub UpcomingLines()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
For Each rng In Range("A1:A100" & LastRow)
If rng <> rng.Offset(1, 0) Then
Range("A" & rng.Row & ":H" & rng.Row).Borders(xlEdgeBottom).Weight = xlThick
End If
Next rng
Application.ScreenUpdating = True
End Sub
I've tried integrating SpecialCells like this:
Sub UpcomingLines()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Set myrange = Range("A1:H" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
For Each rng In Range("A1:A100" & LastRow)
If rng <> rng.Offset(1, 0) Then
Range("A" & myrange.Row & ":H" & rng.Row).Borders(xlEdgeBottom).Weight = xlThick
End If
Next rng
Application.ScreenUpdating = True
End Sub
However, this generates lines in places I don't want them -- basically, the show up between date changes, but also everyplace there is a hidden row, even if there is no date change before or after the hidden row.
Try something like this:
Sub UpcomingLines()
Dim ws As Worksheet, LastRow As Long, c As Range, theDate
Application.ScreenUpdating = False
Set ws = ActiveSheet
ws.Range("A1").CurrentRegion.Borders.LineStyle = xlNone 'remove existing borders
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
theDate = 0
For Each c In ws.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
'different date from previous visible row?
If c.Value <> theDate Then
'add border to top of row if not the first change
If theDate <> 0 Then c.Resize(1, 8).Borders(xlEdgeTop).Weight = xlThick
theDate = c.Value 'remember this date
End If
Next c
Application.ScreenUpdating = True
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