Excel VBA Range Finding and Deletion - excel

I have a couple of questions regarding VBA which I hope you folks can help me with. I'm a very new coder to VBA, so any help you can provide is very much appreciated.
Objective - Remove all rows from "cellRange" if a similar value is found in "valueRange"
Code so far
Sub DeleteRows()
Set valueRange = Worksheets("Delete Rows").Range("A4:A65000")
Set cellRange = Worksheets("Load File").Columns(Worksheets("Delete Rows").Range("F1").Value)
For Each Cel In cellRange.Cells
For Each Value In valueRange.Cells
If Cel.Value = Value.Value Then
Cel.EntireRow.Delete
End If
Next Value
Next Cel
End Sub
Problem 1: valueRange doesn't always have all 65000 rows populated. How can I only make it so that the range only grabs those from A4:(until it hits an empty column)
Problem 2: Similar to problem 1, but the cellRange
Problem 3: Whenever a row is deleted, it seems to affect how the range is set. Meaning that if it deletes row #10 in, then the loop goes to row#11 without checking row #10 again. How can I tell the look to do a second pass or to go through the file again.

P1: Two options here
a) if the Cel.Value is Empty, Exit For
b) proper range selection, refer to this guy here: Excel: Selecting all rows until empty cell
P2: Same as above
P3: As For-Each can't go "backwards" the best you can do is
a) Don't delete the row but store it's number instead e.g. in a Long array, then add a For-Next and delete the "marked" rows like:
For x = UBound(myLongArray)-1 To 0 Step -1
cel(x).EntireRow.Delete
Next x
b) instead of For-Each, store the number of rows (via the ROWS function) in a variable and go through the rows with a 'Step -1' loop

As others mention, you have to step backwards when deleting.
Also, I modified to avoid unnecessary iteration over each cell in ValueRange, instead use the Match() function to check if Cel.Value exists in ValueRange.
Sub DeleteRows()
Dim r as Long
Dim valueRange as Range, cellRange as Range
Dim Cel as Range
Set valueRange = Worksheets("Delete Rows").Range("A4:A65000").End(xlUp) '<~~ Get the last unused row
Set cellRange = Worksheets("Load File").Columns(Worksheets("Delete Rows").Range("F1").Value)
For r = cellRange.Cells.Count to 1 Step -1 '<~~ When deleting rows you must step backwards through the range to avoid the error you are encountering.'
Set Cel = cellRange.Cells(r)
'Check to see if Cel.Value exists in the ValueRange using the "Match" function'
If Not IsError(Application.Match(Cel.Value,ValueRange,False) Then
Cel.EntireRow.Delete
End If
Next r
End Sub

Here you go.
' Declare your variables to get intellisense
Dim rngDelete As Range
Dim cellRange As Range
Dim valueRange As Range
' Get only the rows with data
Set valueRange = Worksheets("Delete Rows").Range("A4")
If valueRange.Offset(1, 0) <> "" Then
Set valueRange = Worksheets("Delete Rows").Range(valueRange, valueRange.End(xlDown))
End If
' Get only the rows with data
Set cellRange = Worksheets("Load File").Cells(Worksheets("Delete Rows").Range("F1").value,1)
If cellRange.Offset(1, 0) <> "" Then
Set cellRange = Worksheets("Load File").Range(cellRange, cellRange.End(xlDown))
End If
Dim cel As Range
Dim value As Range
' make cel your outer since it has more rows
For Each cel In cellRange.Cells
For Each value In valueRange.Cells
If value.value = cel.value Then
' Don't delete it yet but store it in a list
If rngDelete Is Nothing Then
Set rngDelete = cel.EntireRow
Else
Set rngDelete = Union(rngDelete, cel.EntireRow)
End If
' no need to look further
Exit For
End If
Next
Next
' Wipe them out all at once
rngDelete.Delete

Related

Delete duplicate arrays based on column values across several blocks of data

I have been working on automating different parts of the process of formatting a very large data set. I am stuck on trying to automate the "remove duplicates" command across all blocks of my data:
I have blocks of data (9 columns wide, x rows long) as on the image attached. In the column called "#Point ID" are values 0-n. Some values appear once, some values appear more than once. Different blocks have different "#Point ID" columns
I would like to delete all rows in the block where the value in the "#Point ID" column has already occurred (starting from the top, moving down the rows). I would like the deleted rows removed from the blocks, so only the rows (which are blue on the image) with unique values in "#Point ID" column (green on the image) remain.
I have found VBA modules that work on a single block, but I don't know how to make it function across all my blocks. Delete rows in Excel based on duplicates in Column
I have also tried combinations of functions (inc. UNIQUE and SORTBY) without any success.
What's a function or a VBA module that works?
Use this
Public Sub cleanBlock(rng As Range)
Dim vals As Object
Set vals = CreateObject("Scripting.Dictionary")
Dim R As Range
Dim adds As Range
For Each R In rng.Rows
If (vals.exists(R.Cells(1, 2).Value)) Then
If adds Is Nothing Then
Set adds = R
Else
Set adds = Union(adds, R)
End If
Else
vals(R.Cells(1, 2).Value) = True
End If
Next R
Debug.Print (adds.Address)
If Not adds Is Nothing Then adds.Delete shift:=xlUp
Set vals = Nothing
End Sub
Public Sub test()
cleanBlock Range("b3:j20")
cleanBlock Range("l3:t20")
cleanBlock Range("y3:ad20")
End Sub
Remove Duplicates in Areas of a Range
Sub RemoveDupesByAreas()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1") ' adjust!
Dim rg As Range: Set rg = ws.UsedRange.SpecialCells(xlCellTypeConstants)
Dim aCount As Long: aCount = rg.Areas.Count
Dim arg As Range, a As Long
For a = aCount To 1 Step -1
Set arg = rg.Areas(a)
Debug.Print a, arg.Address(0, 0)
' Before running the code with the next line, in the Immediate
' window ('Ctrl+G'), carefully check if the range addresses
' match the areas of your data. If they match, uncomment
' the following line to apply remove duplicates.
'arg.RemoveDuplicates 2, xlYes
Next a
MsgBox "Duplicates removed.", vbInformation
End Sub
Find and FindNext feat. CurrentRegion
Sub RemoveDupesByFind()
Const SEARCH_STRING As String = "Source.Name"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1") ' adjust!
Dim rg As Range: Set rg = ws.UsedRange
Dim fCell As Range: Set fCell = rg.Find( _
SEARCH_STRING, , xlFormulas, xlWhole, xlByRows, xlPrevious)
If fCell Is Nothing Then
MsgBox """" & SEARCH_STRING & """ not found.", vbCritical
Exit Sub
End If
Dim FirstAddress As String: FirstAddress = fCell.Address
Do
fCell.CurrentRegion.RemoveDuplicates 2, xlYes
Set fCell = rg.FindNext(fCell)
Loop Until fCell.Address = FirstAddress
MsgBox "Duplicates removed.", vbInformation
End Sub
Another way, maybe something like this :
Sub test()
Dim rgData As Range
Dim rg As Range: Dim cell As Range
Dim rgR As Range: Dim rgDel As Range
Set rgData = Sheets("Sheet1").UsedRange 'change as needed
Set rgData = rgData.Resize(rgData.Rows.Count - 1, rgData.Columns.Count).Offset(1, 0)
For Each rg In rgData.SpecialCells(xlConstants).Areas
For Each cell In rg.Columns(2).Cells
Set rgR = cell.Offset(0, -1).Resize(1, rg.Columns.Count)
If cell.Value = 0 And cell.Offset(1, 0).Value <> 0 And cell.Offset(0, 1).Value = 0 And cell.Address = rg.Columns(2).Cells(1, 1).Address Then
Else
If Application.CountIf(rg.Columns(2), cell.Value) > 1 And cell.Offset(0, 1).Value = 0 Then
If rgDel Is Nothing Then Set rgDel = rgR Else Set rgDel = Union(rgDel, rgR)
End If
End If
Next cell
Next rg
rgDel.Delete Shift:=xlUp
End Sub
The code assumed that there'll be no blank cell within each block and there will be full blank column (no value at all) between each block. So it sets the usedrange as rgData variable, and loop to each area/block in rgData as rg variable.
Within rg, it loop to each cell in rg column 2, and check if the count of the looped cell value is > 1 and the value of the looped cell.offset(0,1) is zero, then it collect the range as rgDel variable.
Then finally it delete the rgDel.
If you want to step run the code, try to add something like this rg.select ... rgR.select .... after the variable is set. For example, add rgDel.select right before next area, so you can see what's going on.
The code assume that :
the first value right under "#Point" in each block will be always zero. It will
never happen that the value is other than zero.
the next value (after that zero value) is maybe zero again or maybe one.
if there are duplicates (two same value) in column #Point then in column X, it's not fix that the first one will always have value and the second one will always zero value.
If the data is always fix that the first one will always have value and the second one will always zero value (if there are duplicate), I suggest you to use Mr. VBasic2008 or Mr. wrbp answer. Thank you.

Delete all rows containing values outside of a specified numeric range

I am completely new to visual basic. I have a few spreadsheets containing numbers. I want to delete any rows containing numbers outside of specific ranges. Is there a straightforward way of doing this in visual basic?
For example, in this first spreadsheet (image linked) I want to delete rows that contain cells with numbers outside of these two ranges: 60101-60501 and 74132-74532.
Can anyone give me some pointers? Thanks!
Code
You need to call it for your own needs as shown on the routine "Exec_DeleteRows". I assumed that you needed if it is equals or less to the one that you state on your routine. In this example, I will delete the rows where values are between 501-570 and then the ones between 100-200
Sub Exec_DeleteRows()
Call Exec_DeleteRowsInRangeBasedOnNumberValue(Range("C8:H11"), 501, 570)
Call Exec_DeleteRowsInRangeBasedOnNumberValue(Range("C8:H11"), 100, 200)
End Sub
Sub Exec_DeleteRowsInRangeBasedOnNumberValue(RangeToWorkIn As Range, NumPivotToDeleteRowBottom As Double, NumPivotToDeleteRowTop As Double)
Dim RangeRowsToDelete As Range
Dim ItemRange As Range
For Each ItemRange In RangeToWorkIn
If IsNumeric(ItemRange.Value) = False Then GoTo SkipStep1
If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop Then ' 1. If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop
If RangeRowsToDelete Is Nothing Then ' 2. If RangeRowsToDelete Is Nothing
Set RangeRowsToDelete = RangeToWorkIn.Parent.Rows(ItemRange.Row)
Else ' 2. If RangeRowsToDelete Is Nothing
Set RangeRowsToDelete = Union(RangeToWorkIn.Parent.Rows(ItemRange.Row), RangeRowsToDelete)
End If ' 2. If RangeRowsToDelete Is Nothing
End If ' 1. If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop
SkipStep1:
Next ItemRange
If Not (RangeRowsToDelete Is Nothing) Then RangeRowsToDelete.EntireRow.Delete
End Sub
Demo
Delete Rows Containing Wrong Numbers
It is assumed that the data starts in A1 of worksheet Sheet1 in the workbook containing this code (ThisWorkbook) and has a row of headers (2).
This is just a basic example to get familiar with variables, data types, objects, loops, and If statements. It can be improved on multiple accounts.
Option Explicit
Sub DeleteWrongRows()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' worksheet
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' range
Application.ScreenUpdating = False
Dim rrg As Range ' Row Range
Dim rCell As Range ' Cell in Row Range
Dim rValue As Variant ' Value in Cell
Dim r As Long ' Row
Dim DoDelete As Boolean
' Loop backwards through the rows of the range.
For r = rg.Rows.Count To 2 Step -1
Set rrg = rg.Rows(r)
' Loop through cells in row.
For Each rCell In rrg.Cells
rValue = rCell.Value
If IsNumeric(rValue) Then ' is a number
If rValue >= 60101 And rValue <= 60501 Then ' keep
ElseIf rValue >= 74132 And rValue <= 74532 Then ' keep
Else ' delete (outside the number ranges)
DoDelete = True
End If
Else ' is not a number
DoDelete = True
End If
If DoDelete Then ' found a cell containing a wrong value
rCell.EntireRow.Delete
DoDelete = False
Exit For ' no need to check any more cells
'Else ' found no cell containing a wrong value (do nothing)
End If
Next rCell
Next r
Application.ScreenUpdating = True
MsgBox "Rows with wrong numbers deleted.", vbInformation
End Sub
Using Range.Delete is the built-in way of completely erasing a row in Excel VBA. To check an entire row for numbers meeting a certain criteria, you would need a Loop and an If Statement.
To evaluate a lot of values at a faster pace, it is smart to first grab the relevant data off the Excel sheet into an Array. Once in the array, it is easy to set up the loop to run from the first element (LBound) to the final element (UBound) for each row and column of the array.
Also, when deleting a lot of Ranges from a worksheet, it is faster and less messy to first collect (Union) the ranges while you're still looping, and then do the delete as a single step at the end. This way the Range addresses aren't changing during the loop and you don't need to re-adjust in order to track their new locations. That and we can save a lot of time since the application wants to pause and recalculate the sheet after every Deletion.
All of those ideas put together:
Sub Example()
DeleteRowsOutside ThisWorkbook.Worksheets("Sheet1"), Array(60101, 60501), Array(74132, 74532)
End Sub
Sub DeleteRowsOutside(OnSheet As Worksheet, ParamArray Min_and_Max() As Variant)
If OnSheet Is Nothing Then Set OnSheet = ActiveSheet
'Find the Bottom Corner of the sheet
Dim BottomCorner As Range
Set BottomCorner = OnSheet.Cells.Find("*", After:=OnSheet.Range("A1"), SearchDirection:=xlPrevious)
If BottomCorner Is Nothing Then Exit Sub
'Grab all values into an array
Dim ValArr() As Variant
ValArr = OnSheet.Range(OnSheet.Cells(1, 1), BottomCorner).Value
'Check each row value against min & max
Dim i As Long, j As Long, DeleteRows As Range
For i = LBound(ValArr, 1) To UBound(ValArr, 1) 'For each Row
For j = LBound(ValArr, 2) To UBound(ValArr, 2) 'For each column
Dim v As Variant: v = ValArr(i, j)
If IsNumeric(v) Then
Dim BoundaryPair As Variant, Is_Within_A_Boundary As Boolean
Is_Within_A_Boundary = False 'default value
For Each BoundaryPair In Min_and_Max
If v >= BoundaryPair(0) And v <= BoundaryPair(1) Then
Is_Within_A_Boundary = True
Exit For
End If
Next BoundaryPair
If Not Is_Within_A_Boundary Then
'v is not within any acceptable ranges! Mark row for deletion
If DeleteRows Is Nothing Then
Set DeleteRows = OnSheet.Rows(i)
Else
Set DeleteRows = Union(DeleteRows, OnSheet.Rows(i))
End If
GoTo NextRow 'skip to next row
End If
End If
Next j
NextRow:
Next i
If Not DeleteRows Is Nothing Then DeleteRows.EntireRow.Delete
End Sub Exit For 'skip to next row
End If
End If
Next j
Next i
If Not DeleteRows Is Nothing Then DeleteRows.EntireRow.Delete
End Sub
I use a ParamArray to accept a variable number of Min and Max ranges. To keep things tidy, the Min and Max pairs are each in an array of their own. As long as all the numbers in the row are within any of the provided ranges, the row will not be deleted.
Here's some code with Regex and with scripting dictionary that I've been working on. I made this for my purposes, but it may be useful here and to others.
I found a way for selecting noncontinguous cells based on an array and then deleting those cells.
In this case, I selected by row number because VBA prevented deletion of rows due to overlapping ranges.
Sub findvalues()
Dim Reg_Exp, regexMatches, dict As Object
Dim anArr As Variant
Dim r As Range, rC As Range
Set r = Sheets(3).UsedRange
Set r = r.Offset(1).Resize(r.Rows.Count - 1, r.Columns.Count)
Set Reg_Exp = CreateObject("vbscript.regexp")
With Reg_Exp
.Pattern = "^[6-6]?[0-0]?[1-5]?[0-0]?[1-1]?$|^60501$" 'This pattern is for the 60101 to 60501 range.
End With
Set dict = CreateObject("Scripting.Dictionary")
For Each rC In r
If rC.Value = "" Then GoTo NextRC ''skip blanks
Set regexMatches = Reg_Exp.Execute(rC.Value)
If regexMatches.Count = 0 Then
On Error Resume Next
dict.Add rC.Row & ":" & rC.Row, 1
End If
NextRC:
Next rC
On Error GoTo 0
anArr = Join(dict.Keys, ", ")
Sheets(3).Range(anArr).Delete Shift:=xlShiftUp
End Sub

Deleting Rows via For-Loop (within a multi Area Range)

Usually, I would delete Rows using a For-Loop with row-numbers by working backward, which would look similar to this:
For rowIndex = 10 to 1 Step (-1)
'delete Row with current row index
next rowIndex
How do I do this while cycling through a specified cell range? The following code obviously won't work (it will skip a cell/row in the next iteration when the delete command has been executed, check here or here):
Dim someRange as Range
'Note: someRange might be a multi area range (multiple unadjoined cells) within one sheet
Dim singleCell as Range
For each singleCell In SomeRange.Cells
'check for some condition e.g. based (but not limited to) the singleCell's value
If condition = True then
singleCell.EntireRow.Delete
'Note: the deletion has to be done before the next loop-iteration starts
'Unfortunately, this makes solutions like working with Union unfeasible
End If
Next singleCell
Has anyone an idea how to make the second code block work without switching to a "Backward-Row-Number-Loop" (see first code block)? Is there a way to somehow "reset" the singleCell-pointer/counter to a new value so the loop does not skip the next cell/row? Or any other alternative (like make the Range-Loop work backward etc.)? Any hint for a solution would be appreciated, a code snipped as well but if necessary I can do without.
I have to avoid adding the undesired row into an array (range etc.) and deleting the whole array after the loop is done. Unfortunately as a condition for the implementation the row has to be deleted before the next cell is evaluated.
Essentially there might be a case where two cell which rows ought to be deleted will be in the same row. In this case the 2nd cell will be deleted before it's even checked, that's desired behaviour. The solution does not have to but should be expandable to include this case.
EDIT: Another solution I'm thinking about is reversing the range before doing the For-Loop (see here), so far I haven't tried it out though.
Try this code, please:
Sub TestdeleteRows()
Dim sh As Worksheet, someRange As Range, singleCell As Range, rngDel As Range
Set sh = ActiveSheet ' use what sheet you need
Set someRange = sh.Range("A2:A20")
For Each singleCell In someRange.Cells
If singleCell.Value = Empty Then
If rngDel Is Nothing Then
Set rngDel = singleCell
Else
Set rngDel = Union(rngDel, singleCell)
End If
End If
Next
rngDel.EntireRow.Delete xlUp
End Sub
It deletes EntireRow for empty cells. It can be conditioned for everything needed.
'If you are deleting rows downwards based on a criteria, the row number of the next row to be evaluated will be the same as the current deleted row number.
'Please try following.
Sub test()
Dim someRange As Range
'Note: someRange might be a multi area range (multiple unadjoined cells)
within one sheet
Set someRange = Range("B1:B18")
J = someRange.Rows.Count
Dim i As Long
i = 1
Dim singleCell As Long
For singleCell = 1 To someRange.Rows.Count
'check for some condition
If someRange.Cells(singleCell, 1) = 0 Then
someRange.Cells(singleCell, 1).EntireRow.Delete
'now as the row is deleted you should reset the value of singleCell
singleCell = singleCell - 1
'Note: the deletion has to be done before the next loop-iteration starts
End If
i = i + 1
If i = J Then Exit For
'someRange.Rows.Count will be the max number of rows to be evaluated
'otherwise there will be infinite loop and macro wont stop
Next
End Sub
To strictly follow your stated desire to to top down deletion, and to allow for possible multiple hits on one row, and to allow for non-contiguous ranges, I'd suggest not using a for loop, but rather a Do Loop over the Areas and Rows in your someRange, and a For loop over each row (terminate the For when you get a hit). Something like
Sub Demo()
Dim rng As Range, cl As Range
Dim someRange As Range
Dim AreaRange As Range
Dim DeletedRow As Boolean
Dim areaNum As Long
Dim i As Long
' Set your test range, eg
Set someRange = [A1:F3,A8:F10,A16:F19]
areaNum = 1
' Set first row to test
Do
' Track discontiguous range areas
Set AreaRange = someRange.Areas(areaNum)
Set rng = someRange.Areas(areaNum).Rows(1)
Do Until rng Is Nothing
DeletedRow = False
For Each cl In rng.Cells
' test condition, eg empty
If IsEmpty(cl) Then
' update rng to next row. do this before the Delete
Set rng = Application.Intersect(someRange, rng.Offset(1, 0))
' delete row
cl.EntireRow.Delete
DeletedRow = True
' stop looping the row
Exit For
End If
Next
' if not already updated...
If Not DeletedRow Then
Set rng = Application.Intersect(someRange, rng.Offset(1, 0))
End If
Loop
' not all rows in area have been deleted, increment AreaNum
' AreaRange end up in a state where it's not Nothing, and isn't valid
On Error Resume Next
i = 0
i = AreaRange.Count
On Error GoTo 0
If i > 0 Then
areaNum = areaNum + 1
End If
Loop Until areaNum > someRange.Areas.Count
End Sub
Note that this will be quite inefficient, but does meet your stated aims

What's the quickest way to delete all blank rows of an Excel table?

I see several posts about deleting blank rows in a range and others about deleting table rows based on a single blank column, but nothing about deleting entirely blank table rows.
What's the quickest way to do this?
I posted my solution below to help others but I'm interested to see if anyone has a faster method.
Here's a procedure I use to delete blank table rows. I sometimes work with large (for Excel) data sets and this method is faster. It loads table rows into an array, checks the array for blank rows, and performs one range.delete operation at the end.
You use the procedure like this:
Sub Test()
DeleteBlankTableRows ActiveSheet.ListObjects(1)
End Sub
ActiveSheet.ListObjects(1) is (usually) the first table table on the active worksheet.
Here's the actual procedure:
Sub DeleteBlankTableRows(ByVal tbl As ListObject)
Dim rng As Range
Set rng = tbl.DataBodyRange ' Get table data rows range.
Dim DirArray As Variant
DirArray = rng.Value2 ' Save table values to array.
' LOOP THROUGH ARRAY OF TABLE VALUES
Dim rowTMP As Long
Dim colTMP As Long
Dim combinedTMP As String
Dim rangeToDelete As Range
' Loop through rows.
For rowTMP = LBound(DirArray) To UBound(DirArray)
combinedTMP = vbNullString ' Clear temp variable.
' Loop through each cell in the row and get all values combined.
For colTMP = 1 To tbl.DataBodyRange.Columns.Count
combinedTMP = combinedTMP & DirArray(rowTMP, colTMP)
Next colTMP
' Check if row is blank.
If combinedTMP = vbNullString Then
' Row is blank. Add this blank row to the range-to-delete.
If rangeToDelete Is Nothing Then
Set rangeToDelete = tbl.ListRows(rowTMP).Range
Else
Set rangeToDelete = Union(rangeToDelete, tbl.ListRows(rowTMP).Range)
End If
End If
Next rowTMP
' DELETE BLANK TABLE ROWS (if any)
If Not rangeToDelete Is Nothing Then rangeToDelete.Delete
End Sub
This has some advantages over other methods:
SPEED: In a test of a table with 200,000 rows and 8 columns, this method took 19 seconds. That's just over half the 34 seconds the SpecialCells(xlCellTypeBlanks) method needed for an identical table.
IDENTIFIES FULLY BLANK TABLE ROWS: Unlike some other methods (like this one - although it is useful in some situations) this method looks for blanks in every cell of a row instead of just one.
This should work. Not sure if it's faster, but it's another way to do it:
Sub delete_blank_table_rows()
Dim Rng As Range, tempRng As Range
Set Rng = Range("Table1") ' Change as necessary
Set Rng = Range(Cells(Rng.Rows(1).Row, Rng.Columns(1).Column), Cells(Rng.Rows(Rng.Rows.Count).Row, Rng.Columns(Rng.Columns.Count).Column))
Dim i As Long
For i = Rng.Rows.Count To 1 Step -1
Cells(Rng.Rows(i).Row, Rng.Columns(1).Column).Select
Set tempRng = Range(Cells(Rng.Rows(i).Row, Rng.Columns(1).Column), Cells(Rng.Rows(i).Row, Rng.Columns(Rng.Columns.Count).Column))
If WorksheetFunction.CountA(tempRng) = 0 Then
tempRng.Delete shift:=xlUp
End If
Next i
End Sub
Edit: And of course to speed it up you should turn off Screen Updating, Calculation while it runs.
I think this may be faster (you can modify lastrow and lastcol to meet your table dimensions):
Sub delete_rows_blank2()
t = 1
lastrow = ActiveSheet.UsedRange.Rows.Count
lastcol = ActiveSheet.UsedRange.Columns.Count
Do Until t = lastrow
For j = 1 To lastcol
If Cells(t, j) = "" Then
j = j + 1
If j = lastcol Then
Rows(t).Delete
t = t + 1
End If
Else
t = t + 1
End If
Next
Loop
End Sub

How to shift columns with their properties in vba excel

so i have some code that outputs this on a spreasheet:
what i want is that you see those empty columns i need them to be gone and have all the columns beside each other to save space.
so is there a way for me to check if a column is empty and if it is i need to pretty much cut and paste the next bunch of columns onto the empty ones WITH their properties such as color code and border.
any help is much appreciated, and thnx in advance. ^_^ :D
Try WorksheetFunction.CountA(Columns( *REF* )), replacing * REF * with the reference to each column (e.g. using variable and looping through)
If this = 0, the column is empty.
You can then just delete the empty columns, e.g. using If... Then in your loop.
(Have a look at:
http://analysistabs.com/excel-vba/delete-rows-columns/ for example)
Try this:
Sub DeleteColumns()
Dim rng As Range
Dim i As Long
Dim wkSht As Worksheet
Set wkSht = ThisWorkbook.Sheets("Sheet1") '--> enter your sheet name here
Set rng = wkSht.Range("A:Z") '--> set your range here
For i = rng.Columns.Count To 1 Step -1
If Application.CountA(Columns(i).EntireColumn) = 0 Then
Columns(i).Delete
End If
Next i
End Sub
You can also delete all the empty columns together using union as:
Sub DeleteColumns()
Dim rng As Range, delRng As Range
Dim i As Long
Dim wkSht As Worksheet
Set wkSht = ThisWorkbook.Sheets("Sheet2") '--> enter your sheet name here
Set rng = wkSht.Range("A:Z") '--> set your range here
For i = 1 To rng.Columns.Count
If Application.CountA(Columns(i).EntireColumn) = 0 Then
If delRng Is Nothing Then
Set delRng = Columns(i)
Else
Set delRng = Union(delRng, Columns(i))
End If
End If
Next i
delRng.Delete '--> delete all empty columns
End Sub

Resources