I have produced this code to sit on a button that belongs to a UserForm...
Private Sub CommandButton1_Click()
Dim lngWriteRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
lngWriteRow = ws.Cells(Rows.Count, 2).End(xlUp) _
.Offset(12, 0).NextRow
ws.Range("B" & lngWriteRow) = TextBox1.Value
ws.Range("C" & lngWriteRow) = TextBox2.Value
ws.Range("D" & lngWriteRow) = TextBox3.Value
ws.Range("E" & lngWriteRow) = ComboBox1.Value
ws.Range("F" & lngWriteRow) = TextBox4.Value
ws.Range("G" & lngWriteRow) = ComboBox2.Value
End Sub
It wont automatically move to the next row, and will overwrite the row number 14, when i want it to update 15 when 14 has data in it, then when 15 does, update 16 and so on...
Any ideas?
Since you're only placing data in columns B onwards, you should look at those columns, not column A as your code is currently doing. This should fix it:
lngWriteRow = ws.Cells(Rows.Count, 2).End(xlUp).Offset(12, 0).Row + 1
While John seems to have hit the nail on the head, I think you can further simplify your code like this. See my comment under where lngWriteRow is assigned:
Private Sub CommandButton1_Click()
Dim lngWriteRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
With ws
'-> if you are going to offset 12 rows then add 1 more, just offset to 13 and be done!
lngWriteRow = .Cells(.Rows.Count, 2).End(xlUp).Offset(13, 0).Row
.Range("B" & lngWriteRow) = TextBox1.Value
.Range("C" & lngWriteRow) = TextBox2.Value
.Range("D" & lngWriteRow) = TextBox3.Value
.Range("E" & lngWriteRow) = ComboBox1.Value
.Range("F" & lngWriteRow) = TextBox4.Value
.Range("G" & lngWriteRow) = ComboBox2.Value
End With
End Sub
Related
I am trying to replicate data entered from one worksheet(sheet1) into another(sheet2) and then have it save hourly on a separate line each time on sheet2. I am pulling unique cells from each row rather than the entire row from sheet1 to be saved to sheet 2 with all data being in a specific order and outputting to a single row with one value per cell and creating a new line each time it is saved. For my usage, Sheet 1 will always stay open as the active sheet where changes will be made and the data will periodically save to Sheet2 while sheet1 remains selected. I am saving every 5 seconds at this stage for troubleshooting purposes.
I need assistance on pulling values from unique cells on approximately 30 rows from sheet1 and saving it to specific cells on sheet2 while sheet1 remains open and active.
I am having the following issues so far:
1. the data will replicate on sheet1 instead of sheet2 when i have sheet1 selected and open instead of writing to sheet2 as i need it to when sheet1 is being viewed/modified actively.
here is my code so far:
Option Explicit
Public dTime As Date
Sub ValueStore()
Dim dTime As Date
Range("A" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("A2").Value
Range("B" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("B2").Value
Range("C" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("C2").Value
Range("D" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("D2").Value
Range("E" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("E2").Value
Range("F" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("F2").Value
Range("G" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("G2").Value
Range("H" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("H2").Value
Range("I" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("I2").Value
Range("J" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("J2").Value
Range("K" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("K2").Value
Range("L" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("L2").Value
Range("M" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("M2").Value
Range("N" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("N2").Value
Range("O" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("O2").Value
Range("P" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("P2").Value
Range("Q" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("Q2").Value
Range("R" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("R2").Value
Range("S" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("S2").Value
Range("T" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("T2").Value
Range("U" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("U2").Value
Range("V" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("V2").Value
Range("W" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("W2").Value
Range("X" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("X2").Value
Range("Y" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("Y2").Value
Range("Z" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("Z2").Value
Range("AA" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("AA2").Value
Range("AB" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("AB2").Value
Range("AC" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("AC2").Value
Range("AD" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("AD2").Value
Range("AE" & Cells(Rows.Count).Row).End(xlUp).Offset(1, 0).Value = Range("AE2").Value
Call StartTimer1
End Sub
Sub StartTimer1()
dTime = Now + TimeValue("00:00:05")
Application.OnTime dTime, "ValueStore", Schedule:=True
End Sub
Sub StopTimer1()
On Error Resume Next
Application.OnTime dTime, "ValueStore", Schedule:=False
End Sub
Here is a sample of your code with the additions and changes.
1-Create worksheet variables
2-Make the last row a variable
3-Since your are writing to sheet2, put your code inside a With - End With statement
4-Ensue you put the ws1 variable in front of the range you are copying from
Dim dTime As Date
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Set ws2 = ActiveWorkbook.Worksheets("Sheet2")
Dim lRow As Long
lRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
With ws2
Range("A1:A" & lRow).Offset(1).Value = ws1.Range("A2").Value
Range("B1:B" & lRow).Offset(1).Value = ws1.Range("B2").Value
Range("C1:C" & lRow).Offset(1).Value = ws1.Range("C2").Value
End With
This is for an Microsoft Excel VBA macro. What it is supposed to do, for every row, when "Late" is entered into column C, to highlight the cell 2 spaces to the left and Range of cells 3 spaces to the right through 43. So example is C4 contains "Late", highlight A4 and F4:AW4. Same goes for the word "Hold" just a different color.
Private Sub Highlight_Condition(ByVal Target As Range)
Dim lastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = lastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i & ":AW" & i).ClearContents
.Range("F" & i & ":AW" & i).ClearContents
End If
Next i
Application.EnableEvents = True
End With
End Sub
This should work for you...
Private Sub Highlight_Condition(ByVal Target As Range)
Dim lastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = lastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i & ":AW" & i).ClearContents
.Range("F" & i & ":AW" & i).ClearContents
End If
Next i
Application.EnableEvents = True
End With
End Sub
Tested and seems to work fine for me :)
... C4 contains "Late" ... (emphasis mine)
This seems to indicate that Late may be part of a longer string. I will code to that effect.
Conditional formatting rules are a quick method of achieving your cell highlighting and respond as soon as values in column C change without rerunning the sub procedure (unless more values are added below the lastRow).
Option Explicit
Sub Macro1()
Const TEST_COLUMN As String = "D"
Dim lastRow As Long, sSheetName As String
sSheetName = ActiveSheet.Name
With Worksheets(sSheetName)
lastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
With .Range("A4:A" & lastRow & ", F4:AW" & lastRow)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=isnumber(search(""late"", $c4))"
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 39
.FormatConditions.Add Type:=xlExpression, Formula1:="=isnumber(search(""hold"", $c4))"
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 43
End With
End With
End Sub
Great! I wanted to run this in the worksheet and not as a module. So i added a few extra lines and ByVal Target As Range to fire everytime a change is made in the range but it doesn't seem to work. Am i missing something?
Private Sub Highlight_Condition(ByVal Target As Range)
Dim LastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = LastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i).EntireRow.Interior.ColorIndex = xlNone
End If
Next i
Application.EnableEvents = True
End With
End Sub
I have some data, for the first column date, it contains two dates.
Then I have the fund code and the categories, the last column is the categories value.
How shall I put them into matrix format, for example, the categories is horizontal and the value correspond to the fund name and categories and the date.
Following code should be helpful.
Option Explicit
Sub Demo()
With Application
.ScreenUpdating = False 'stop screen flickering
.Calculation = xlCalculationManual 'prevent calculation while execution
End With
Dim i As Long, lastrow As Long, tblLastRow As Long, tblLastColumn As Long
Dim dict As Object
Dim rng As Variant
Dim ws As Worksheet
Dim cel As Range, dateRng, fundCodeRng As Range, categoryRng As Range, valueRng As Range
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Worksheets("Sheet1") 'change Sheet1 to your worksheet
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row 'get last row with data
'set ranges for date, fund code, category and value to be used later in code
Set dateRng = .Range("A2:A" & lastrow)
Set fundCodeRng = .Range("B2:B" & lastrow)
Set categoryRng = .Range("C2:C" & lastrow)
Set valueRng = .Range("D2:D" & lastrow)
'get unique records for date and fund coding combined together
For i = 2 To lastrow
dict(.Cells(i, 1).Value & "|" & .Cells(i, 2).Value) = dict(.Cells(i, 1).Value & "|" & .Cells(i, 2).Value)
Next
With .Range("F2").Resize(dict.Count) 'date and fund code will be displayed from cell F2
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.Cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items)
End With
'empty dictionary
dict.RemoveAll
Set dict = Nothing
Set dict = CreateObject("Scripting.Dictionary")
'get unique categories and display as header
rng = .Range("C1:C" & lastrow)
For i = 2 To UBound(rng)
dict(rng(i, 1) & "") = ""
Next
.Range("H1").Resize(1, UBound(dict.Keys()) + 1).Value = dict.Keys 'categories will be displayed from column H
tblLastRow = .Range("F" & Rows.Count).End(xlUp).Row 'get last row in new table
tblLastColumn = Cells(1, Columns.Count).End(xlToLeft).Column 'get last column of category in new table
'display corresponding values for date, fund code and category
For Each cel In .Range(.Cells(2, 8), .Cells(tblLastRow, tblLastColumn)) 'Cells(2, 8) represent Cell("H2")
cel.FormulaArray = "=IFERROR(INDEX(" & valueRng.Address & ",MATCH(1,(" & dateRng.Address & "=" & .Cells(cel.Row, 6) & ")*(" & fundCodeRng.Address & "=""" & .Cells(cel.Row, 7) & """)*(" & categoryRng.Address & "=""" & .Cells(1, cel.Column) & """),0)),"""")"
cel.Value = cel.Value
Next cel
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
See image for reference.
EDIT :
If Fund Code could be numbers also then replace
cel.FormulaArray = "=IFERROR(INDEX(" & valueRng.Address & ",MATCH(1,(" & dateRng.Address & "=" & .Cells(cel.Row, 6) & ")*(" & fundCodeRng.Address & "=""" & .Cells(cel.Row, 7) & """)*(" & categoryRng.Address & "=""" & .Cells(1, cel.Column) & """),0)),"""")"
with
cel.FormulaArray = "=IFERROR(INDEX(" & valueRng.Address & ",MATCH(1,(" & dateRng.Address & "=" & .Cells(cel.Row, 6) & ")*(Text(" & fundCodeRng.Address & ",""0"")=""" & .Cells(cel.Row, 7) & """)*(" & categoryRng.Address & "=""" & .Cells(1, cel.Column) & """),0)),"""")"
Sheet 1 has columns A-T. Some columns of Sheet 1 have formulas and others have a dropdown list.
Sheet 2 has columns A-P. I want to be able to paste the Sheet 1 data in Sheet 2-- The data generated as a result of formulas and drop downs. Also in a way, that if I change anything in Sheet 1 it changes on the other sheet. I want to be able to do this for multiple columns.
The thing is that Sheet 1 and Sheet 2 columns are not true to each other. I mean Column A of Sheet 1 is Column C in Sheet 2 etc..
Right now, I have simply equaled the cells using formula on both sheets to make this work. I don't wish to continue it this way. Macro will be better.
Thank you! Please help.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2")
hC = "AO"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:T"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range("C" & Lr).Value = Range("C" & R).Value
.Range("D" & Lr).Value = Range("D" & R).Value
.Range("E" & Lr).Value = Range("E" & R).Value
.Range("F" & Lr).Value = Range("F" & R).Value
.Range("G" & Lr).Value = Range("G" & R).Value
.Range("H" & Lr).Value = Range("H" & R).Value
.Range("I" & Lr).Value = Range("I" & R).Value
.Range("J" & Lr).Value = Range("J" & R).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("L" & Lr).Value = Range("K" & R).Value
.Range("M" & Lr).Value = Range("L" & R).Value
.Range("N" & Lr).Value = Range("M" & R).Value
.Range("O" & Lr).Value = Range("N" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
Edited Code (3_31_3017)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Route_Sheet")
hC = "AP"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:AL"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range(.Cells(Lr, "C"), .Cells(Lr, "J")).Value = Range(Cells(R, "C"), Cells(R, "J")).Value
.Range(.Cells(Lr, "L"), .Cells(Lr, "O")).Value = Range(Cells(R, "K"), Cells(R, "N")).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range("Q" & Lr).Value = Range("U" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
We need at least one thing to know that row(x) in Sheet 1 is related to row(y) in Sheet 2. this can be done by adding unique identifier for each row as #tigeravatar mentioned or by adding one formula in unused column in row(x) in Sheet 1 relating to row(y) in Sheet 2.
In Sheet 1 Module add this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2")
hC = "U" 'Change this to any unused column and You can hide it
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:T"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
' Add here all columns you need like :
'=====================================
.Range("C" & Lr).Value = Range("A" & R).Value
.Range("A" & Lr).Value = Range("B" & R).Value
'...etc
'=====================================
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
Edit:
Right click on "Master" sheet tab and select View Code and paste this code in it:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2") 'Change "Sheet 2" to your target sheet name like "Route_Sheet" or "Lists"
hC = "AO"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:AH"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row
If Not (Lr = 1 And .Range(hC & Lr).Value = vbNullString) Then Lr = Lr + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range(.Cells(Lr, "C"), .Cells(Lr, "J")).Value = Range(Cells(R, "C"), Cells(R, "J")).Value
.Range(.Cells(Lr, "L"), .Cells(Lr, "O")).Value = Range(Cells(R, "K"), Cells(R, "N")).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
This is a Worksheet Event that run automatically when user change any cell inside Columns("A:AH").
If you want to run it manually you can add new sub in Module1:
Sub Test()
With sheets("Master").Range("A2:A50") ' change this range to all rows you need like "A5:A100"
.Value = .Value
End With
End Sub
Or:
Sub Test()
With Sheets("Master")
Application.Run .CodeName & ".Worksheet_Change", .Range("A1:A50") 'change this range to all rows you need like "A5:A100"
End With
End Sub
I am trying to create a macro that looks for "Total net" and "Program Operation net" in column C. Once located, the macro compares the rows of these two cells and of their values match then row of "Total Net" get deleted.
This is my code so far...
Sub DeletingEmptyPages()
Dim WS As Worksheet
For Each WS In Sheets
Dim Mystring As String
Dim MystringII As String
MystringII = "Total Net"
Mystring = "Program Operating Net"
Dim n As Long
Dim nlast As Long
Dim rw As Range
Set rw = ActiveWorkbook.ActiveSheet.UsedRange.Rows
nlast = rw.count
For n = nlast To 9 Step -1
If (Column(c).Value = MystringII And Column(c).Value = Mystring) Then
rw.Rows(n).Delete
End If
Next n
Next WS
End Sub
I suppose that when both strings exist in column "C", you want to compare if columns "A" and "B" are equal in both rows. You can use the following code and easily adapt it if more columns need to be compared on the matched rows:
Sub Delete_DuplicateTotalNet()
Dim WS As Worksheet, row1 As Long, row2 As Long
For Each WS In Sheets
With WS
On Error Resume Next
row1 = WorksheetFunction.Match("Total Net", .Columns("C"), 0)
row2 = WorksheetFunction.Match("Program Operating Net", .Columns("C"), 0)
If Err.Number <> 0 Then GoTo NextWS
If .Range("A" & row1).Value = .Range("A" & row2).Value And _
.Range("B" & row1).Value = .Range("B" & row2).Value Then
.Rows(row1).Delete
End If
End With
NextWS:
Err.Clear
Next WS
End Sub
This is what it looks like but causes a runtime error
Sub Delete_DuplicateTotalNet()
Dim WS As Worksheet, row1 As Long, row2 As Long, rng As Long
For Each WS In Sheets
On Error GoTo NextWS
With WS
If WS.Visible = xlSheetVisible Then
row1 = WorksheetFunction.Match("Total Net", .Columns(3), 0)
row2 = WorksheetFunction.Match("Program Operating Net", .Columns(3), 0)
If .Range("D" & row1).Value = .Range("D" & row2).Value And _
.Range("E" & row1).Value = .Range("E" & row2).Value And _
.Range("F" & row1).Value = .Range("F" & row2).Value And _
.Range("G" & row1).Value = .Range("G" & row2).Value And _
.Range("H" & row1).Value = .Range("H" & row2).Value And _
.Range("I" & row1).Value = .Range("I" & row2).Value And _
.Range("J" & row1).Value = .Range("J" & row2).Value And _
.Range("K" & row1).Value = .Range("K" & row2).Value Then
.Rows(row1).Delete
End If
End If
End With
NextWS:
Err.Clear
Next WS
End Sub