Deleting worksheet row based on value tied to a table - excel

I have a worksheet with two tables on it located starting in column B. In Column A I have a COUNTA formula that is tied to a delete blank rows button. My code works great to delete the table row but i need it to delete the entire worksheet row so that it also deletes the formula in column A instead of it continuously shifting down as rows are added or deleted.
The trouble is that I have two tables on the sheet so I need the deletion row action to refer only to the Local_1 table and the loop to stop when it reaches the end of that table.
Any suggestions on how to delete the entire row and not just the table row?
Dim i As Long
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:=pswStr
Rows.EntireRow.Hidden = False
With ActiveSheet.ListObjects("Local_1")
For i = .ListRows.Count To 1 Step -1
If .ListRows(i).Range.Cells(0) <= 0 Then
.ListRows(i).Delete
End If
Next i
End With

List Entire Row
To not cramp your style, just replace
If .ListRows(i).Range.Cells(0) <= 0 Then
.ListRows(i).Delete
End If
with
If .ListRows(i).Range.Cells(1) <= 0 Then 'as Tim Williams mentioned
'.ListRows(i).Delete
ActiveSheet.Rows(Range(.DataBodyRange.Address).Row + i - 1).Delete
End If
But (to cramp your style) I would strongly suggest you use (declare) variables like this:
Sub ListEntireRow()
Dim i As Long
Dim oWs As Worksheet
Dim oList As ListObject
Application.ScreenUpdating = False
Set oWs = ActiveSheet
Set oList = oWs.ListObjects("Local_1")
oWs.Unprotect Password:=pswStr
Rows.EntireRow.Hidden = False
With oList
For i = .ListRows.Count To 1 Step -1
If .ListRows(i).Range.Cells(1) <= 0 Then
' .ListRows(i).Delete
oWs.Rows(Range(.DataBodyRange.Address).Row + i - 1).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Now you have the Intellisense for the Worksheet (oWs) and the ListObject (oList) working for you i.e. you can see their properties and methods.

Related

VBA Copy and paste entire row if cell matches list of IDs, but do not paste if list contains blank cell or cell with ""

I have what I thought would be a simple script, but I have some some strange results.
Goal: Identify specific IDs in a SOURCE sheet using a list of IDs on a Translator Sheet. When found, copy the entire row to and OUTPUT sheet.
The output has strange results that I can't figure out.
Returns all results instead of the limited list. AND results are in weird groupings. (First result is on row 21 and only has 9 rows of data, the next group has 90 rows of data, starting on row 210, then blank rows, then 900 rows of data, etc.
Results do not start in row 2.
Full code is below attempts:
Attempts:
I first searched the SOURCE sheet based on one ID that was hard coded as a simple test and it worked. but when I changed the code to search a range (z21:z), two things happened: 1, it returns everything in the Source file in multiples of 9 as stated above, AND as you can imagine, the time to complete skyrocketed from seconds to minutes. I think I missed a add'l section of code to identify the range??
Old Code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("D62D627EB404207DE053D71C880A3E05") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
New code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I)** Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
1a. I believe one issue is that the Translator list has duplicates. Second, it is searching the entire column Z. Second issue may be that The list in Translator is generated via a formula in column Z, thus if the formula is false, it will insert a "" into the cell. I seek the code to NOT paste those rows where the cell content is either a "" or is a true blank cell. Reason: The "" will cause issues when we try to load the Output file into a downstream system because it is not a true blank cell.
Results in wrong location: When the script is complete, my first result does not start on Row 2 as expected. I thought the clear contents would fix this, but maybe a different clear function is required? or the clear function is in the wrong place? Below screenshot shows how it should show up. It is in the same columns but doesn't start until row 21.
enter image description here
Slow code: I have a command that copies and pastes of the first row from SOURCE to OUTPUT. My code is cumbersome. There has to be an easier way. I am doing this copy and paste just in case the source file adds new columns in the future.
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Thank you for all your help.
Option Explicit
Sub MoveRowBasedOnCellValuefromlist()
'Updated by xxx 2023.01.18
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("SOURCE").UsedRange.Rows.Count
J = Worksheets("Output").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Output").UsedRange) = 0 Then J = 0
End If
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Set xRg = Worksheets("SOURCE").Range("B2:B" & I)
On Error Resume Next
Application.ScreenUpdating = False
'NOTE - There are duplicates in the Translator list. I only want it to paste the first instance.
'Otherwise, I need to create an =Unique() formula and that seems like unnecessary work.
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I) Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Try this out - using Match as a fast way to check if a value is contained in your lookup list.
Sub MoveRowBasedOnCellValuefromlist()
Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range
Set wb = ThisWorkbook 'for example
Set wsSrc = wb.Worksheets("SOURCE")
Set wsOut = wb.Worksheets("Output")
Set wsTrans = wb.Worksheets("Translator")
Set rngList = wsTrans.Range("Z21:Z" & wsTrans.Cells(Rows.Count, "Z").End(xlUp).Row)
ClearSheet wsOut
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("A2") 'first paste destination
Application.ScreenUpdating = False
For Each c In wsSrc.Range("B2:B" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True
End Sub
'clear a worksheet
Sub ClearSheet(ws As Worksheet)
With ws.Cells
.ClearContents
.ClearFormats
End With
End Sub

Delete Empty Columns VBA

I would like to delete all of the empty columns in my worksheet. I found some code online, but it is not working as I wish.
Sub deleteEmptyColumns()
' Set variables
Dim i As Long
Dim lngLastColumn As Long
' Get last column
lngLastColumn = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
' Turn off screen updating
Application.ScreenUpdating = False
' Loop from last column cell to 1
For i = lngLastColumn To 1 Step -1
' Check if column has any values
If Application.WorksheetFunction.CountA(Columns(i)) = 0 Then
' Delete column
Columns(i).Delete
End If
Next i
' Turn on screen updating
Application.ScreenUpdating = True
End Sub
Here is a screenshot of my workbook. There are lots of empty columns, and I would like to delete them.
Any help would be greatly appreciated!
Assuming missing data is missing uniformly and last row is data and not totals or something else the following solution should work even if there are formulas but the formulas will not work after this solution so back things up:
Sub Delete_Empty_Columns()
Dim Last_Column_No As Long
Dim Last_Row_No As Long
Dim i As Long
Last_Column_No = Columns(ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1).Column
Last_Row_No = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row - 1
'Coppy everything in used range and paste only values back
'This will clear all formulas
ActiveSheet.Range("A1", Cells(Last_Row_No, Last_Column_No)).Copy
ActiveSheet.Range("A1").PasteSpecial xlPasteValues
For i = 1 To Last_Column_No
If Cells(Last_Row_No, i) = "" Then
Columns(i).Delete
End If
Next i
End Sub

How to use MailMerge field as a condition for deleting a row of table in Word? VBA code needed

Creating a bill/letter:
This is a Excel-to-Word-bill-creation attempt to automatize work process.
I have used MailMerge to add fields from Excel to Word tables. I have 3 separate tables in Word, each with different number of rows. In rows 1 to n-1, there are 4 columns, and in the nth row there are 2 columns. I would like to use macro to delete:
whole table, if a cell(n,2) value is 0 ("n" - last row of the table, "0" - MailMerge field of value "0.00").
a row, if a cell(i,4) value is 0 (1 < "i" < n, "0" - MailMerge field of value "0.00").
Sub DeleteEmptyTablerowsandcolumns()
Application.ScreenUpdating = False
Dim Tbl As Table, cel As Cell, i As Long, n As Long
With ActiveDocument
For Each Tbl In .Tables
n = Tbl.Rows.Count
m = Tbl.Range.Rows(n).Cells.Count
If (Tbl.Cell(n, 2).Range.Text = "0.00") Then
Tbl.Delete
Selection.TypeBackspace
Else: For i = n - 1 To 2 Step -1
If Len(Tbl.Cell(i, 4).Range.Text) <= 2 Then
Tbl.Rows(i).Delete
End If
Next i
End If
Next Tbl
End With
Application.ScreenUpdating = True
End Sub
Right now, I cannot target cell values with MailMerge fields, for the code to work. The whole code would be a great thing to get. I assume solution is trivial, but still out of the reach.
Thanks in advance!
You infer that you're using mailmerge but, if that is so, there will be no mergefields in the output once the merge has completed. The fact you're still finding mergefields therefore suggests you're at most doing a mailmerge preview. Try the following, which completes the merge then does the necessary processing. You can either run the code manually as you've apparently been doing, or by choosing Finish and Merge>Edit Individual Documents.
Sub MailMergeToDoc()
Application.ScreenUpdating = False
Dim Tbl As Table, r As Long
ActiveDocument.MailMerge.Execute
For Each Tbl In ActiveDocument.Tables
With Tbl
If Split(.Range.Cells(.Range.Cells.Count).Range, vbCr)(0) = "0.00" Then
.Delete
Else
For r = .Rows.Count - 1 To 2 Step -1
If Split(.Cell(r, 4).Range.Text, vbCr)(0) = "0.00" Then .Rows(r).Delete
Next r
End If
End With
Next Tbl
Application.ScreenUpdating = True
End Sub
As coded, the macro assumes the cells to be tested contain "0.00"; if that's not what they contain post-merge, edit the code accordingly.

Consolidating VBA IF, THEN statements that repeat the same logic in a continuous row set

I am a novice when it comes to writing macro code in VBA. I'm working with Excel 2010, and I think I have a simple problem. I want to hide rows in my worksheet that meet the condition of having a zero sum result in column AJ. I was able to figure how to do this for one row and then repeat for each subsequent row, but I know there must a better/more efficient means of writing this. Can anyone help me re-word this code so that it considers the range of rows 8-14 all together rather than considering each row one at a time? This would reduce my run-time and decrease the possibility for errors. Thank you in advance!
Sub Hide_1()
'
' Master Macro
If ActiveSheet.Range("AJ8") = 0 Then
Rows("8").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ9") = 0 Then
Rows("9").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ10") = 0 Then
Rows("10").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ11") = 0 Then
Rows("11").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ12") = 0 Then
Rows("12").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ13") = 0 Then
Rows("13").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ14") = 0 Then
Rows("14").EntireRow.Hidden = True
End If
End Sub
This will loop through your range and hide the row where the value is 0:
Sub HideRows()
Dim rng As Range, cl As Range
Set rng = Range("AJ8:AJ14")
For Each cl In rng
If cl = 0 Then
cl.EntireRow.Hidden = True
End If
Next cl
End Sub
How about:
Public Sub HideEntireRow(cellToCheck As range, valueToHide As Variant)
If cellToCheck.Value2 = valueToHide Then cellToCheck.EntireRow.Hidden = True
End Sub
Public Sub Hide_2()
Dim cell As range
For Each cell In ActiveSheet.range("AJ10:AJ14")
Call HideEntireRow(cell, 0)
Next cell
End Sub
For a range as small as you are working with, an autofilter will not offer any visible performance boost, but you should use autofilters by default rather than loops. There are plenty of instances where loops are necessary, but this doesn't appear to be one of them.
Here is how you can filter your sheet (starting in row 8), hiding any rows that have a 0 in column AJ. Note that I am calculating the last row in your sheet. If you need to hard-code a specific range, you can easily modify this:
Sub FilterZeroRows()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
lastRow = ws.Range("AJ" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("AJ8:AJ" & lastRow)
' keep any rows that don't have 0 visible
rng.AutoFilter field:=1, Criteria1:="<>0"
End Sub

VBA Macro to delete unchecked rows using marlett check

I don't really have much of a background in VBA, but I'm trying to create a macro where, on the push of a button all rows that do not have a check mark in them in a certain range are deleted. I browsed some forums, and learned about a "marlett" check, where the character "a" in that font is displayed as a check mark. Here is the code I have to generate the "marlett check" automatically when clicking a cell in the A column in the appropriate range:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A10:A111")) Is Nothing Then
Target.Font.Name = "Marlett"
If Target = vbNullString Then
Target = "a"
Else
Target = vbNullString
End If
End If
End Sub
I then have another macro (assigned to a button) that actually deletes the rows without a check mark in the "A" column when the button is pressed:
Sub delete_rows()
Dim c As Range
On Error Resume Next
For Each c in Range("A10:A111")
If c.Value <> "a" Then
c.EntireRow.Delete
End If
Next c
End Sub
Everything works, but the only problem is that I have to press the button multiple times before all of the unchecked rows are deleted!! It seems like my loop is not working properly -- can anyone please help??
Thanks!
I think this may be due to how you're deleting the rows, you might be skipping a row after every delete.
You might want to change your for-each for a regular for loop. so you can control the index you'r working on. see this answer or the other answers to the question to see how to do it.
Heres a modified version that should suit your (possible) problem.
Sub Main()
Dim Row As Long
Dim Sheet As Worksheet
Row = 10
Set Sheet = Worksheets("Sheet1")
Application.ScreenUpdating = False
Do
If Sheet.Cells(Row, 1).Value = "a" Then
'Sheet.Rows(Row).Delete xlShiftUp
Row = Row + 1
Else
'Row = Row + 1
Sheet.Rows(Row).Delete xlShiftUp
End If
Loop While Row <= 111
Application.ScreenUpdating = True
End Sub
Update
Try the edit I've made to the if block, bit of a guess. Will look at it when I have excel.
It does go into an infinite loop regardless of the suggested change.
The problem was when it got near the end of your data it continually found empty rows (as theres no more data!) so it kept deleting them.
The code below should work though.
Sub Main()
Dim Row As Long: Row = 10
Dim Count As Long: Count = 0
Dim Sheet As Worksheet
Set Sheet = Worksheets("Sheet1")
Application.ScreenUpdating = False
Do
If Sheet.Cells(Row, 1).Value = "a" Then
Row = Row + 1
Else
Count = Count + 1
Sheet.Rows(Row).Delete xlShiftUp
End If
Loop While Row <= 111 And Row + Count <= 111
Application.ScreenUpdating = True
End Sub

Resources