Excel Data Replication + Automated Saving PT 2 - vba

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

Related

Highlight cells based on cell content with Excel VBA

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

vba to sort the data into matrix form

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)),"""")"

VBA for matching Sheet 1 columns to Sheet 2 columns

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

MS Excel VBA -Exiting Loop

UPDATED:
Lastrow = .Range("C" & Rows.Count).End(xlUp).Row
DurcurrRowIn = currRowIn
Do
DurcurrRowIn = DurcurrRowIn + 1
Set DurlookFor = wb.ActiveSheet.Cells(currRowIn, "C") ' value to find
Set Durlookforin = wb.ActiveSheet.Range("C" & DurcurrRowIn & ":C" & Lastrow)
'Set Durlookforin = wb.ActiveSheet.Range("C:C")
On Error Resume Next
DurStart = Application.WorksheetFunction.Index(wb.ActiveSheet.Range("F" & DurcurrRowIn & ":F" & Lastrow), WorksheetFunction.Match(DurlookFor, Durlookforin, 0))
DurEnd = Application.WorksheetFunction.Index(wb.ActiveSheet.Range("G" & DurcurrRowIn & ":G" & Lastrow), WorksheetFunction.Match(DurlookFor, Durlookforin, 0))
DurStart = Format(DurStart, "mm-dd-yyyy")
Dur1 = DurEnd - DurStart
Dur = Dur + Dur1
Loop Until Durlookforin Is Nothing
Need help exiting the loop once all the employeeIDs have been found with the Index/Match
Here is a sample of my worksheet:
Test Excel

Delete empty rows using VBA - MS Excel

I am looking to see if there is a more efficient way to achieve the result below, so it can be extended if needed.
I'm using this to clean up large spreadsheets that have the rows C-Z blank. I imagine there should be a way to clean it up so that it doesn't have to double in size if I need to clean up a spreadsheet with data from C to AZ.
It's been a while since I used VBA, I found the code below online. (counting ROW B as the spreadsheet in question had an empty ROW A)
Sub delem()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 1 Step -1
If Range("C" & r).Value = "" And Range("D" & r).Value = "" And Range("E" & r).Value = "" And Range("F" & r).Value = "" And Range("G" & r).Value = "" And Range("H" & r).Value = "" And Range("I" & r).Value = "" And Range("J" & r).Value = "" And Range("K" & r).Value = "" And Range("L" & r).Value = "" And Range("M" & r).Value = "" And Range("N" & r).Value = "" And Range("O" & r).Value = "" And Range("P" & r).Value = "" And Range("Q" & r).Value = "" And Range("R" & r).Value = "" And Range("S" & r).Value = "" And Range("T" & r).Value = "" And Range("U" & r).Value = "" And Range("V" & r).Value = "" And Range("W" & r).Value = "" And Range("X" & r).Value = "" And Range("Y" & r).Value = "" And Range("Z" & r).Value = "" Then Rows(r).Delete
Next r
End Sub
Thanks!
Just add an inner loop to go through the columns you care about. This will actually run much faster, as VBA doesn't short-circuit the If statement (all of the conditionals are evaluated). But with the loop, you can exit early if you find a value anywhere:
Sub delem()
Dim last As Long
Dim current As Long
Dim col As Long
Dim retain As Boolean
last = Cells(Rows.Count, "B").End(xlUp).Row
For current = last To 1 Step -1
retain = False
For col = 3 To 26
If Cells(current, col).Value <> vbNullString Then
retain = True
Exit For
End If
Next col
If Not retain Then Rows(current).Delete
Next current
End Sub
The Excel worksheet function COUNTA is a clean way to test if a range is empty.
Sub delem()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 1 Step -1
'This function Counts the number of cells that are not empty
If WorksheetFunction.CountA(Range(Cells(r, 3), Cells(r, 26)) = 0 Then
Rows(r).Delete
End If
Next r
End Sub