How to find the true Last Cell in any Worksheet - vba

This question is now answered elegantly, thanks to Chris Neilsen, see the answer below. It is the one I will use from now on. The solution reliably finds the last cell in a Worksheet, even when cells are hidden by Filters, Groups or Local hiding of rows.
The discussion may be informative to some, so I have provided an optimised version of my own code too. It demonstrates how to save and restore Filters, uses #Chis's ideas for finding the last Row, and records Hidden Row Ranges in a short Variant array from which they are finally restored.
A test Workbook that explores and tests all the solutions proposed discussed is also available to download here.
THE FULL QUESTION AND DISCUSSION, AS UPDATED
There is much discussion here and elsewhere on finding last cells in Excel Worksheets. The Range.SpecialCells method has limitations and does not always find the true last cell. This is particularly true if Worksheet.AutoFilters are active. The code below solves the problem and returns the correct result, even if Filters are active, cells are Grouped and Hidden, or Rows or Columns are Hidden using Hide/Unhide. However, the method is not simple. Does anybody know of a better method that is consistently reliable?
The 'true last cell' is understood to be the intersection of the last row containing data or formulae and the last column containing them. Formatting may extend past it.
Credits and thanks for good ideas: to readify and sancho s.
The code below tests and works in my application in Excel 2010 and requires that Scripting.Runtime is referenced in the VBIDE. It contains inline comments that document what it is doing and why. Also, the variable names are deliberately explanatory. Sorry, but this makes them long.
In some circumstances it may not restore the exact Rows that were hidden when it is called. I have never had this happen.
Edit 1 to the question
Thanks to the 3 kind respondees on 1/3/2016.
This follows on from brettdj marking the question as already answered. Regrettably, I do not believe that to be true. At least, not unless UsedRange can be trusted in all circumstances. Though problems with SpecialCells are hard to reproduce, previous experience with the values provided by SpecialCells discourages reliance on them.
brettdj's post Return a range from A1 to the true last used cell provides a solution, GetRange. It is one amongst others but appears to be clearly the best. I have tested it and all the solutions proposed in this thread. In my tests, none of them are able to find the last cell when a filter is active without trusting UsedRange. brettdj, of high reputation, clearly thinks otherwise but it appears to me that I really have detected a real issue.
To demonstrate:
See the following test Sheet. All rows and columns are exposed in this view. Note Row 19 with the text 'Row to hide with filter' in H19. Also note that there is information in Row 20 at B20 and in Column J at J11. (Obviously, as this is a test, there is nothing in J20 the Cell whose reference is the correct answer to the Question):
Tests were run on the Sheet above but with a filter active (emphasised by a red circle in the image below) which removes row 19 from view. During the tests the Column Group J:K was collapsed but the Row Group over 19:20 was left visible.
These are the results (the true answer is J20):
Gettrange() by brettdj in the referenced Answer gives
"Range is A1:B20."
TrueLastCell() by Gary's Student gives "The
TRUE last cell is B20" and also may sometimes be very expensive, looping from very high row and column numbers if the UsedRange goes to the end of a largely empty Sheet. (Also, the screen shot in the answer shows C11 when it should be F11.)
GetTrueLastCell(WS) by PatrickK gets the right answer, J20 but
it relies entirely on UsedRange which I understand is not possible,
or I would never have started on this!
GetTrueLastCell(WS,,) (by me, the code below, though complicated) gives $J$20.
In the unlikely case that this is Operating System specific, my test was run on {you're not allowed to laugh -:)} Vista Home Premium. My excuse is that it is 64Bit OS on a lightning fast 8 core machine, even if it is ageing.
Excel 2010, 32 bit Version 14.0.7166.5000.
Edit 2 in response
In response to chris neilsen's request for validation and a test file upload it is no longer here. The short answer is : The problem is all too reproducible on Windows 10 running Office 2013 15.0.4797.1003 as well as on Vista - Office 2010. Sadly, this is real. The Workbook from which the images were taken now contains the code for each the suggestions made here (to date 2 March 2016). The public file downloads OK and reproduces the results on a Windows 7/Office 2010 machine. To run the tests, look for the Module TestSolutionsProposed in the VBIDE. The Debug.Prints from the tests give identical same results on W10, W7, Vista and Office 2010 & 2013 (correct answer is J20):
Brettdj's GetRange gives: Range is A1:B20
WS usedrange = $A$1:$K$20
PatrickK's GetTrueLastCell gives Found last cell = $K$20
Gary's Student's TrueLastCell gives: The TRUE last cell is B20
My GetTrueLastCell (with RemoveFiltersAsBoolean = False) gives: Last cell address is B20
My GetTrueLastCell (with RemoveFiltersAsBoolean = True) gives: Last cell address is J20
#brettdj - please can you restore the status of this question? Surely it is reproducible by others - how could the results be specific to three separate systems I can get access to but not to others? Only removal of the filters gives the correct answer. Note: The filter has to be both present and active to show the problem; as uploaded, the Test Workbook is set to give the results above; it is not enough to have AutoFitlerMode = True. One of the filters must have a filter criterion active - in the example H19 is hidden.
Private Function GetTrueLastCell(ws As Excel.Worksheet, _
Optional lRealLastRow As Long, _
Optional lRealLastColumn As Long, _
Optional RemoveFiltersAsBoolean As Variant = False) As Range
'Purpose:
'Finds the cell at the intersection of the last Row containing any data and the last Column containing any data,
' even if some cells are hidden by Filters, Grouping or are locally Hidden. If there are no filters uses a simple method.
'Returns: the LastCell as a Range; Optionally returns Row and Column indeces.
' If the WS has no data or is not a WS, returns GetTrueLastCell=Nothing & lRealLastRow=0 & RealLastColumn=0
'Developed by extension of ideas from:
' 'Readify' for ideas about saving and restoring filters,
' see: https://stackoverflow.com/questions/9489126/in-excel-vba-how-do-i-save-restore-a-user-defined-filter
' 'Sancho s' 24/12/2014, see https://stackoverflow.com/questions/24612874/finding-the-last-cell-in-an-excel-sheet
'Written by Neil Dunlop 29/2/2016
'History: 2016 03 03 added optimisation of the reapplication of filters following discussion on StackOverFlow wiht
' thanks to Chris Neilsen for review and comments and ideas - see here:
' https://stackoverflow.com/questions/35712424/how-to-find-the-true-last-cell-in-any-worksheet
'Notes:
'This will find the last cell even if rows are Hidden by any means.
' This is partly accomplished by setting Lookin:=xlFormulas,
' and partly by removing and restoring filters that prevent .Find looking in a cell.
'Requirements:
' The reference to Microsoft Scripting Runtime must be present in the VBIDE's Tools>References list.
Dim FilteredRange As Range, rng As Range
Dim wf As Excel.WorksheetFunction
Dim MyCriteria1 As Scripting.Dictionary
Dim lr As Long, lr2 As Long, lr3 As Long
Dim i As Long, j As Long, NumFilters As Long
Dim CurrentScreenStatus As Boolean, LastRowHidden As Boolean
Dim FilterStore() As Variant, OutlineHiddenRow() As Variant
If Not RemoveFiltersAsBoolean Then GoTo JUSTSEARCH
CurrentScreenStatus = Excel.Application.ScreenUpdating
Excel.Application.ScreenUpdating = False
On Error GoTo BADWS
If ws.AutoFilterMode Then
'Save all active Filters
With ws.AutoFilter
If .Filters.Count > 0 Then
Set FilteredRange = .Range
For i = 1 To .Filters.Count
If .Filters(i).On Then
NumFilters = NumFilters + 1
ReDim Preserve FilterStore(0 To 4, 1 To NumFilters)
FilterStore(0, NumFilters) = i 'The Column to which the filter applies
'If there are only 2 Filters they will be in Criteria1 and Criteria2.
'Above 2 Filters, Criteria1 contains all the filters in a Scripting Dictionary
FilterStore(1, NumFilters) = .Filters(i).Count 'The number of conditions active within this filter
Select Case .Filters(i).Count
Case Is = 1 'There is 1 filter in Criteria1
FilterStore(2, NumFilters) = .Filters(i).Criteria1
Case Is = 2 'There are 2 Filters in Criteria1 and Criteria2
FilterStore(2, NumFilters) = .Filters(i).Criteria1
FilterStore(3, NumFilters) = .Filters(i).Criteria2
Case Else 'There are many filters, they need to be in a Scripting Dictionary in Criteria1
Set MyCriteria1 = CreateObject("Scripting.Dictionary")
MyCriteria1.CompareMode = vbTextCompare
For j = 1 To .Filters(i).Count
MyCriteria1.Add Key:=CStr(j), Item:=.Filters(i).Criteria1(j)
Next j
Set FilterStore(2, NumFilters) = MyCriteria1
End Select
If .Filters(i).Operator Then
FilterStore(4, NumFilters) = .Filters(i).Operator
End If
End If
Next i
End If ' .Filters.Count > 0
End With
'Check for and store any hidden Outline levels applied to the Rows.
'At this stage the last cell is not known, so the best available estimate , UsedRange,
' is used in the Row loop. The true maximum row number with data may be less than the
' highest row from UsedRange. The code below reduces the maximum estimated efficiently.
'It is believed that UsedRange is never too small; it it were, then the hidden properties
' of some rows may not be stored and will therefore not be restored later.
'---------get a true last row---------------------------------------------------------
Set rng = ws.Range(ws.Cells(1, 1), ws.UsedRange.Cells(ws.UsedRange.Cells.CountLarge))
Set wf = Application.WorksheetFunction
With rng 'Code from Chris Neilsen
lr = .Rows.Count + .Row - 1
lr2 = lr \ 2
lr3 = lr2 \ 2
Do While (lr - lr2) > 30
'Debug.Print "r", lr2, lr
If wf.CountA(.Rows(lr2 & ":" & lr)) = 0 Then
lr = lr2
lr2 = lr3
lr3 = lr2 \ 2
Else
lr3 = lr2
lr2 = (lr + lr2) \ 2
End If
Loop
For i = lr To 1 Step -1
If wf.CountA(.Rows(i)) <> 0 Then Exit For
Next i
lr = i
End With ' rng
'---------record and unhide any hidden Row--------------------------------------------
j = 0
LastRowHidden = False
For i = 1 To lr
If (Not ws.Rows(i).Hidden And LastRowHidden) Then
'End of a Hidden Rows Range, record the Range
Set OutlineHiddenRow(2, j) = ws.Rows(OutlineHiddenRow(1, j) & ":" & i - 1)
LastRowHidden = False
ElseIf ws.Rows(i).Hidden And Not LastRowHidden Then 'Start of Hidden Rows Range, record the Row
j = j + 1
ReDim Preserve OutlineHiddenRow(1 To 2, 1 To j) ' 1 -first row found to be Hidden, 2 - Range of Hidden Rows(i:j)
If i <> lr Then
OutlineHiddenRow(1, j) = i
LastRowHidden = True
Else 'Last line in range is hidden all on its own
Set OutlineHiddenRow(2, j) = ws.Rows(i & ":" & i)
End If
ElseIf LastRowHidden And ws.Rows(i).Hidden And i = lr Then 'Special case is for Hidden Range ending on last Row
Set OutlineHiddenRow(2, j) = ws.Rows(OutlineHiddenRow(1, j) & ":" & i)
Else
'Nothing to do
End If
Next i
NumFilters = j
'Remove the AutoFilter, if any of the filters were On.
' This changes the hidden setting for ALL Rows (but NOT Columns) to visible
' irrespective of the reason for their having become hidden (Filter, Group, local Hide).
If NumFilters > 0 Then ws.AutoFilterMode = False
End If ' WS.AutoFilterMode
JUSTSEARCH:
'Search for the last cell that contains any sort of 'formula'.
'xlPrevious ensures that the search starts from the end of the last Row or Column (it's the next cell after (1,1)).
'LookIn:=xlFormulas ensures that the search includes a search across Hidden data.
' However, if ANY filters are active the search NO LONGER LOOKS IN HIDDEN CELLS. Also the reverse search
' starts at the end of the column or row containing (1,1) instead of starting at the very end row and column.
' This is why all filters have to be stored, removed and reapplied to find the correct end cell.
lRealLastColumn = ws.Cells.Find(What:="*", _
After:=ws.Cells(1, 1), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False, _
MatchByte:=False, _
SearchFormat:=False).Column
If lr = 0 Then
lRealLastRow = ws.Cells.Find(What:="*", _
After:=ws.Cells(1, 1), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False, _
MatchByte:=False, _
SearchFormat:=False).Row
Else
lRealLastRow = lr
End If
Set GetTrueLastCell = ws.Cells(lRealLastRow, lRealLastColumn)
'Restore the saved Filters to their Rows.
If NumFilters Then
'Restore the original AutoFilter settings
FilteredRange.AutoFilter
With ws.AutoFilter
For i = 1 To UBound(FilterStore, 2)
If FilterStore(4, i) Then 'There is an Operator
If FilterStore(1, i) > 2 Then 'There is a ScriptingDictionary for Criteria1
FilteredRange.AutoFilter Field:=FilterStore(0, i), _
Criteria1:=FilterStore(2, i).Items, _
Criteria2:=FilterStore(3, i), _
Operator:=FilterStore(4, i)
Else 'Criteria 1 is a string
FilteredRange.AutoFilter Field:=FilterStore(0, i), _
Criteria1:=FilterStore(2, i), _
Criteria2:=FilterStore(3, i), _
Operator:=FilterStore(4, i)
End If
Else 'No Operator
If FilterStore(1, i) > 2 Then 'There is a ScriptingDictionary for Criteria1
FilteredRange.AutoFilter Field:=FilterStore(0, i), _
Criteria1:=FilterStore(2, i).Items
Else 'Criteria 1 is a string
FilteredRange.AutoFilter Field:=FilterStore(0, i), _
Criteria1:=FilterStore(2, i)
End If
End If
Next i
End With
End If ' NumFilters
If NumFilters > 0 Then
'Restore the Hidden status of any Rows that were revealed by setting WS.AutoFilterMode = False.
'Rows, not columns are filtered. Columns' Hidden status does not need to be restored
' because AutoFilter does not unhide Columns.
For i = 1 To NumFilters
OutlineHiddenRow(2, i).Hidden = True 'Restore the hidden property to the stored Row Range
Next i
End If ' NumFilters > 0
GoTo ENDFUNCTION
BADWS:
lRealLastRow = 0
lRealLastColumn = 0
Set GetTrueLastCell = Nothing
ENDFUNCTION:
Set wf = Nothing
Set MyCriteria1 = Nothing
Set FilteredRange = Nothing
Excel.Application.ScreenUpdating = CurrentScreenStatus
End Function

Based on #Gary's method, but optimised to work fast when the UsedRange is Large but not reflective of the True Last Cell (as can happen when a cell on the extreames of a worksheet is inadvertently formatted)
It works by, starting with the UsedRange, counting cells in half the range and halving the referenced test range above or below the split point depending on the count result, and repeating until it reaches < 5 rows/columns, then uses a linear search from there.
Function TrueLastCell( _
ws As Excel.Worksheet, _
Optional lRealLastRow As Long, _
Optional lRealLastColumn As Long _
) As Range
Dim lrTo As Long, lcTo As Long, i As Long
Dim lrFrom As Long, lcFrom As Long
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
With ws.UsedRange
lrTo = .Rows.Count
lcTo = .Columns.Count
lrFrom = lrTo \ 2
Do While (lrTo - lrFrom) > 2
If wf.CountA(.Rows(lrFrom & ":" & lrTo)) = 0 Then
lrTo = lrFrom - 1
lrFrom = lrFrom \ 2
Else
lrFrom = (lrTo + lrFrom) \ 2
End If
Loop
If wf.CountA(.Rows(lrFrom & ":" & lrTo)) = 0 Then
lrTo = lrFrom - 1
Else
For i = lrTo To lrFrom Step -1
If wf.CountA(.Rows(i)) <> 0 Then
Exit For
End If
Next i
lrTo = i
End If
lcFrom = lcTo \ 2
Do While (lcTo - lcFrom) > 2
If wf.CountA(Range(.Columns(lcFrom), .Columns(lcTo))) = 0 Then
lcTo = lcFrom - 1
lcFrom = lcFrom \ 2
Else
lcFrom = (lcTo + lcFrom) \ 2
End If
Loop
If wf.CountA(Range(.Columns(lcFrom), .Columns(lcTo))) = 0 Then
lcTo = lcFrom - 1
Else
For i = lcTo To 1 Step -1
If wf.CountA(.Columns(i)) <> 0 Then
Exit For
End If
Next i
lcTo = i
End If
Set TrueLastCell = .Cells(lrTo, lcTo)
lRealLastRow = lrTo + .Row - 1
lRealLastColumn = lcTo + .Column - 1
End With
End Function
On my hardware it runs in about 2ms on a sheet with UsedRange extending to the sheet limits and True Last Cell at F5, and 0.1ms when UsedRange reflects the True Last Cell at F5
Edit: slightly more optimised search

UsedRange may be erroneous, (it may be too large), but we can start with its outer limits and work inwards:
Sub TrueLastCell()
Dim lr As Long, lc As Long, i As Long
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
ActiveSheet.UsedRange
With ActiveSheet.UsedRange
lr = .Rows.Count + .Row - 1
lc = .Columns.Count + .Column - 1
End With
For i = lr To 1 Step -1
If wf.CountA(Rows(i)) <> 0 Then
Exit For
End If
Next i
For i = lc To 1 Step -1
If wf.CountA(Cells(lr, i)) <> 0 Then
MsgBox "The TRUE last cell is " & Cells(lr, i).Address(0, 0)
Exit Sub
End If
Next i
End Sub

Great question.
As you note, Find failes with AutoFilter. As an alternative to looping through the filters, or the range loop used by another answer you could
Copy the sheet and remove the AutoFilter
use xlformulas in the Find routine which caters to hidden cells
So something lke this:
Sub GetRange()
'by Brettdj, http://stackoverflow.com/questions/8283797/return-a-range-from-a1-to-the-true-last-used-cell
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim ws As Worksheet
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
ActiveSheet.Copy
Set ws = ActiveSheet
With ws
.AutoFilterMode = False
Set rng1 = ws.Cells.Find("*", ws.[a1], xlFormulas, , xlByRows, xlPrevious)
Set rng2 = ws.Cells.Find("*", ws.[a1], xlFormulas, xlPart, xlByColumns, xlPrevious)
If Not rng1 Is Nothing Then
Set rng3 = Range([a1], Cells(rng1.Row, rng2.Column))
MsgBox "Range is " & rng3.Address(0, 0)
Debug.Print "Brettdj's GetRange gives: Range is " & rng3.Address(0, 0) 'added for this test by ND
'if you need to actual select the range (which is rare in VBA)
Application.GoTo rng3
Else
MsgBox "sheet is blank", vbCritical
End If
.Parent.Close False
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

I think you can utilize the .UsedRange property from the Worksheet object. Try below:
Option Explicit
Function GetTrueLastCell(WS As Worksheet) As Range
With WS
If .UsedRange.Count = 1 Then
Set GetTrueLastCell = .UsedRange
Else
Set GetTrueLastCell = .Range(Split(.UsedRange.Address, ":")(1))
End If
End With
End Function

Best way I know to find "true Last Cell" is to use 2 steps:
Pick last cell of UsedRange (i.e. UsedRange.Cells.CountLarge)
Move left & up until you find last non-empty row & column with CountA (i.e. WorksheetFunction.CountA(Range)), as it is fast, and works with Hidden / AutoFiltered / Grouped ranges.
This takes some time, so I've written an optimized code for the second step.
Then I found #Chris' code edited on Nov 30, 2019, and it looked similar, though I was wondering why so different. I compared (...did my best to do apple v apple), and was surprised by the results.
If my tests are reliable, then all what matters is how many searches you do with CountA. I call it cycle - it is actually the number of CountA functions!
My routine does up to 34 cycles, and #Chris' routine seems to do up to 32..80+ cycles. His code seems to test the same ranges repeatedly.
Please have a look at the test table Link, see my test results in VBA notes, and watch Immediate for your live results. You may test with any content, or even use an ActiveSheet in your own WorkBook. Play with parameters in VBA at "==== PARAMETERS TO BE CHANGED ====". You may zoom to 10%-15% to see painted cells showing the search ranges for each cycle. That's where the number of cycles becomes visible.
Note: I have not found any side-effects or errors with this so far. I avoid using Range.Find, and changing its parameters behind the scenes. Some users will learn it the hard way... - like I did, when I then replaced text in the entire workbook, just to find it out days later.
Note2: This is my first post, please excuse possible glitches here.
Function GetLastSheetCellRng(ws As Excel.Worksheet) As Range
'Returns the [Range] of last used cell of the specified [Worksheet], located in the cross-section of the bottom row and right column with non-empty cells
Dim wf As Excel.WorksheetFunction: Set wf = Application.WorksheetFunction
Dim Xfound&, Yfound&, Xfirst&, Yfirst&, Xfrom&, Yfrom&, Xto&, Yto As Long
With ws
'1. step: UsedRange last cell
Set GetLastSheetCellRng = .UsedRange.Cells(.UsedRange.Cells.CountLarge) 'Getting UsedRange last cell
Yfound = GetLastSheetCellRng.Row: Xfound = GetLastSheetCellRng.Column
'2. step: Check non-empty cells in UsedRange last cell row & column
'If not found, then search up for last non-empty row, and search left for last non-empty column
If (wf.CountA(.Rows(Yfound)) = 0) And (Yfound > 1) Then
Yto = Yfound
Yfrom = Yto \ 2
Yfirst = 0
Do
If wf.CountA(.Range(.Rows(Yfrom), .Rows(Yto))) <> 0 Then
Yfirst = Yfrom
Yfrom = (Yfirst + Yto + 0.5) \ 2
Else
Yto = Yfrom - 1
Yfrom = (Yfrom + Yfirst) \ 2
End If
Loop Until Yfirst = Yfrom
If Yfirst = 0 Then
Yfound = 1 'If no cell found, then 1st row returned
Else
Yfound = Yfirst
End If
End If
If (wf.CountA(.Columns(Xfound)) = 0) And (Xfound > 1) Then
Xto = Xfound
Xfrom = Xto \ 2
Xfirst = 0
Do
If wf.CountA(.Range(.Columns(Xfrom), .Columns(Xto))) <> 0 Then
Xfirst = Xfrom
Xfrom = (Xfirst + Xto + 0.5) \ 2
Else
Xto = Xfrom - 1
Xfrom = (Xfrom + Xfirst) \ 2
End If
Loop Until Xfirst = Xfrom
If Xfirst = 0 Then
Xfound = 1 'If no cell found, then 1st column returned
Else
Xfound = Xfirst
End If
End If
Set GetLastSheetCellRng = .Cells(Yfound, Xfound)
End With
End Function

Related

Deleting rows with values based on a column

I have a monthly base with almost 373,000 lines. Of these, part has a low value or is blank. I'd like to erase this lines.
I have part of this code to delete those that have zero. How to create a code that joins the empty row conditions (column D) in a more agile way.
Thanks
Sub DelRowsZero()
Dim i As Long
For i = Cells(Rows.Count, "D").End(xlUp).Row To 2 Step -1
If Cells(i, "D") = 0 Then Rows(i).Delete
Next i
End Sub
How about:
Sub ZeroKiller()
Dim N As Long, ToBeKilled As Range
Dim i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If Cells(i, "D").Value = 0 Or Cells(i, "D").Value = "" Then
If ToBeKilled Is Nothing Then
Set ToBeKilled = Cells(i, "D")
Else
Set ToBeKilled = Union(ToBeKilled, Cells(i, "D"))
End If
End If
Next i
If Not ToBeKilled Is Nothing Then
ToBeKilled.EntireRow.Delete
End If
End Sub
This assumes that A is the longest column. If this is not always the case, use:
N = Range("A1").CurrentRegion.Rows.Count
I am concerned about the 375K lines, who knows how long this will take to run.
Sub Button1_Click()
Dim i As Long
For i = Cells(Rows.Count, "D").End(xlUp).Row To 2 Step -1
If Cells(i, "D") = 0 Or Cells(i, "D") = "" Then
Rows(i).Delete
End If
Next i
End Sub
I'm curious to know if this works for others, it just uses the "replace" 0 values to blanks, then uses specialcells to delete the blank rows. My test of 38K rows takes 3 seconds.
Sub FindLoop()
Dim startTime As Single
startTime = Timer
'--------------------------
Columns("D:D").Replace What:="0", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Columns("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'---------------------------------
Debug.Print Timer - startTime
End Sub
There's apparently an argument to be made, that deleting rows as you find them would be faster than deleting them all at once.
So I ran the below code with 36000 rows of =RANDBETWEEN(0, 10) in columns A and B (and then copy+paste special/values), and it completed thrice in 32 seconds and dusts.
Uncommenting the currentValue assignment and replacing the array subscript accesses with currentValue comparisons adds 2.5 seconds overhead; uncommenting the IsError check adds another 3.5 seconds overhead - but then the code won't blow up if the checked cells have the slightest chance of containing some #REF! or #VALUE! error.
Every time I ran it, ~4000 rows ended up being deleted.
Note:
No implicit ActiveSheet references. The code works against Sheet2, which is the code name for Worksheets("Sheet2") - a globally scoped Worksheet object variable that you get for free for any worksheet that exists at compile-time. If the sheet you're running this against exists at compile-time, use its code name (that's the (Name) property in the Properties toolwindow / F4).
Range is hard-coded. You already know how to get the last row with data, so I didn't bother with that. You'll want to dump your working range in a variant array nonetheless.
The commented-out code can be ignored/deleted if there's no way any of the cells involved have any chance of ever containing a worksheet error value.
Public Sub SpeedyConditionalDelete()
Dim startTime As Single
startTime = Timer
'1. dump the contents into a 2D variant array
Dim contents As Variant
contents = Sheet2.Range("A1:B36000").Value2
'2. declare your to-be-deleted range
Dim target As Range
'3. iterate the array
Dim i As Long
For i = LBound(contents, 1) To UBound(contents, 1)
'4. get the interesting current value
'Dim currentValue As Variant
'currentValue = contents(i, 1)
'5. validate that the value is usable
'If Not IsError(currentValue) Then
'6. determine if that row is up for deletion
If contents(i, 1) = 0 Or contents(i, 1) = vbNullString Then
'7. append to target range
If target Is Nothing Then
Set target = Sheet2.Cells(i, 1)
Else
Set target = Union(target, Sheet2.Cells(i, 1))
End If
End If
'End If
Next
'8. delete the target
If Not target Is Nothing Then target.EntireRow.Delete
'9. output timer
Debug.Print Timer - startTime
End Sub
Of course 375K rows will run much longer than 32-38 seconds, but I can't think of a faster solution.

How to embed a 'lastrow' in a VBA code [duplicate]

How can I find the last row that contains data in a specific column and on a specific sheet?
How about:
Function GetLastRow(strSheet, strColumn) As Long
Dim MyRange As Range
Set MyRange = Worksheets(strSheet).Range(strColumn & "1")
GetLastRow = Cells(Rows.Count, MyRange.Column).End(xlUp).Row
End Function
Regarding a comment, this will return the row number of the last cell even when only a single cell in the last row has data:
Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
You should use the .End(xlup) but instead of using 65536 you might want to use:
sheetvar.Rows.Count
That way it works for Excel 2007 which I believe has more than 65536 rows
Simple and quick:
Dim lastRow as long
Range("A1").select
lastRow = Cells.Find("*",SearchOrder:=xlByRows,SearchDirection:=xlPrevious).Row
Example use:
cells(lastRow,1)="Ultima Linha, Last Row. Youpi!!!!"
'or
Range("A" & lastRow).Value = "FIM, THE END"
function LastRowIndex(byval w as worksheet, byval col as variant) as long
dim r as range
set r = application.intersect(w.usedrange, w.columns(col))
if not r is nothing then
set r = r.cells(r.cells.count)
if isempty(r.value) then
LastRowIndex = r.end(xlup).row
else
LastRowIndex = r.row
end if
end if
end function
Usage:
? LastRowIndex(ActiveSheet, 5)
? LastRowIndex(ActiveSheet, "AI")
Public Function LastData(rCol As Range) As Range
Set LastData = rCol.Find("*", rCol.Cells(1), , , , xlPrevious)
End Function
Usage: ?lastdata(activecell.EntireColumn).Address
All the solutions relying on built-in behaviors (like .Find and .End) have limitations that are not well-documented (see my other answer for details).
I needed something that:
Finds the last non-empty cell (i.e. that has any formula or value, even if it's an empty string) in a specific column
Relies on primitives with well-defined behavior
Works reliably with autofilters and user modifications
Runs as fast as possible on 10,000 rows (to be run in a Worksheet_Change handler without feeling sluggish)
...with performance not falling off a cliff with accidental data or formatting put at the very end of the sheet (at ~1M rows)
The solution below:
Uses UsedRange to find the upper bound for the row number (to make the search for the true "last row" fast in the common case where it's close to the end of the used range);
Goes backwards to find the row with data in the given column;
...using VBA arrays to avoid accessing each row individually (in case there are many rows in the UsedRange we need to skip)
(No tests, sorry)
' Returns the 1-based row number of the last row having a non-empty value in the given column (0 if the whole column is empty)
Private Function getLastNonblankRowInColumn(ws As Worksheet, colNo As Integer) As Long
' Force Excel to recalculate the "last cell" (the one you land on after CTRL+END) / "used range"
' and get the index of the row containing the "last cell". This is reasonably fast (~1 ms/10000 rows of a used range)
Dim lastRow As Long: lastRow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row - 1 ' 0-based
' Since the "last cell" is not necessarily the one we're looking for (it may be in a different column, have some
' formatting applied but no value, etc), we loop backward from the last row towards the top of the sheet).
Dim wholeRng As Range: Set wholeRng = ws.Columns(colNo)
' Since accessing cells one by one is slower than reading a block of cells into a VBA array and looping through the array,
' we process in chunks of increasing size, starting with 1 cell and doubling the size on each iteration, until MAX_CHUNK_SIZE is reached.
' In pathological cases where Excel thinks all the ~1M rows are in the used range, this will take around 100ms.
' Yet in a normal case where one of the few last rows contains the cell we're looking for, we don't read too many cells.
Const MAX_CHUNK_SIZE = 2 ^ 10 ' (using large chunks gives no performance advantage, but uses more memory)
Dim chunkSize As Long: chunkSize = 1
Dim startOffset As Long: startOffset = lastRow + 1 ' 0-based
Do ' Loop invariant: startOffset>=0 and all rows after startOffset are blank (i.e. wholeRng.Rows(i+1) for i>=startOffset)
startOffset = IIf(startOffset - chunkSize >= 0, startOffset - chunkSize, 0)
' Fill `vals(1 To chunkSize, 1 To 1)` with column's rows indexed `[startOffset+1 .. startOffset+chunkSize]` (1-based, inclusive)
Dim chunkRng As Range: Set chunkRng = wholeRng.Resize(chunkSize).Offset(startOffset)
Dim vals() As Variant
If chunkSize > 1 Then
vals = chunkRng.Value2
Else ' reading a 1-cell range requires special handling <http://www.cpearson.com/excel/ArraysAndRanges.aspx>
ReDim vals(1 To 1, 1 To 1)
vals(1, 1) = chunkRng.Value2
End If
Dim i As Long
For i = UBound(vals, 1) To LBound(vals, 1) Step -1
If Not IsEmpty(vals(i, 1)) Then
getLastNonblankRowInColumn = startOffset + i
Exit Function
End If
Next i
If chunkSize < MAX_CHUNK_SIZE Then chunkSize = chunkSize * 2
Loop While startOffset > 0
getLastNonblankRowInColumn = 0
End Function
Here's a solution for finding the last row, last column, or last cell. It addresses the A1 R1C1 Reference Style dilemma for the column it finds. Wish I could give credit, but can't find/remember where I got it from, so "Thanks!" to whoever it was that posted the original code somewhere out there.
Sub Macro1
Sheets("Sheet1").Select
MsgBox "The last row found is: " & Last(1, ActiveSheet.Cells)
MsgBox "The last column (R1C1) found is: " & Last(2, ActiveSheet.Cells)
MsgBox "The last cell found is: " & Last(3, ActiveSheet.Cells)
MsgBox "The last column (A1) found is: " & Last(4, ActiveSheet.Cells)
End Sub
Function Last(choice As Integer, rng As Range)
' 1 = last row
' 2 = last column (R1C1)
' 3 = last cell
' 4 = last column (A1)
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Last = Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
Case 4:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Last = R1C1converter("R1C" & Last, 1)
For i = 1 To Len(Last)
s = Mid(Last, i, 1)
If Not s Like "#" Then s1 = s1 & s
Next i
Last = s1
End Select
End Function
Function R1C1converter(Address As String, Optional R1C1_output As Integer, Optional RefCell As Range) As String
'Converts input address to either A1 or R1C1 style reference relative to RefCell
'If R1C1_output is xlR1C1, then result is R1C1 style reference.
'If R1C1_output is xlA1 (or missing), then return A1 style reference.
'If RefCell is missing, then the address is relative to the active cell
'If there is an error in conversion, the function returns the input Address string
Dim x As Variant
If RefCell Is Nothing Then Set RefCell = ActiveCell
If R1C1_output = xlR1C1 Then
x = Application.ConvertFormula(Address, xlA1, xlR1C1, , RefCell) 'Convert A1 to R1C1
Else
x = Application.ConvertFormula(Address, xlR1C1, xlA1, , RefCell) 'Convert R1C1 to A1
End If
If IsError(x) Then
R1C1converter = Address
Else
'If input address is A1 reference and A1 is requested output, then Application.ConvertFormula
'surrounds the address in single quotes.
If Right(x, 1) = "'" Then
R1C1converter = Mid(x, 2, Len(x) - 2)
Else
x = Application.Substitute(x, "$", "")
R1C1converter = x
End If
End If
End Function
I would like to add one more reliable way using UsedRange to find the last used row:
lastRow = Sheet1.UsedRange.Row + Sheet1.UsedRange.Rows.Count - 1
Similarly to find the last used column you can see this
Result in Immediate Window:
?Sheet1.UsedRange.Row+Sheet1.UsedRange.Rows.Count-1
21
Public Function GetLastRow(ByVal SheetName As String) As Integer
Dim sht As Worksheet
Dim FirstUsedRow As Integer 'the first row of UsedRange
Dim UsedRows As Integer ' number of rows used
Set sht = Sheets(SheetName)
''UsedRange.Rows.Count for the empty sheet is 1
UsedRows = sht.UsedRange.Rows.Count
FirstUsedRow = sht.UsedRange.Row
GetLastRow = FirstUsedRow + UsedRows - 1
Set sht = Nothing
End Function
sheet.UsedRange.Rows.Count: retrurn number of rows used, not include empty row above the first row used
if row 1 is empty, and the last used row is 10, UsedRange.Rows.Count will return 9, not 10.
This function calculate the first row number of UsedRange plus number of UsedRange rows.
Last_Row = Range("A1").End(xlDown).Row
Just to verify, let's say you want to print the row number of the last row with the data in cell C1.
Range("C1").Select
Last_Row = Range("A1").End(xlDown).Row
ActiveCell.FormulaR1C1 = Last_Row
get last non-empty row using binary search
returns correct value event though there are hidden values
may returns incorrect value if there are empty cells before last non-empty cells (e.g. row 5 is empty, but row 10 is last non-empty row)
Function getLastRow(col As String, ws As Worksheet) As Long
Dim lastNonEmptyRow As Long
lastNonEmptyRow = 1
Dim lastEmptyRow As Long
lastEmptyRow = ws.Rows.Count + 1
Dim nextTestedRow As Long
Do While (lastEmptyRow - lastNonEmptyRow > 1)
nextTestedRow = Application.WorksheetFunction.Ceiling _
(lastNonEmptyRow + (lastEmptyRow - lastNonEmptyRow) / 2, 1)
If (IsEmpty(ws.Range(col & nextTestedRow))) Then
lastEmptyRow = nextTestedRow
Else
lastNonEmptyRow = nextTestedRow
End If
Loop
getLastRow = lastNonEmptyRow
End Function
Function LastRow(rng As Range) As Long
Dim iRowN As Long
Dim iRowI As Long
Dim iColN As Integer
Dim iColI As Integer
iRowN = 0
iColN = rng.Columns.count
For iColI = 1 To iColN
iRowI = rng.Columns(iColI).Offset(65536 - rng.Row, 0).End(xlUp).Row
If iRowI > iRowN Then iRowN = iRowI
Next
LastRow = iRowN
End Function
Sub test()
MsgBox Worksheets("sheet_name").Range("A65536").End(xlUp).Row
End Sub
This is looking for a value in column A because of "A65536".
The first line moves the cursor to the last non-empty row in the column. The second line prints that columns row.
Selection.End(xlDown).Select
MsgBox(ActiveCell.Row)

VBA selecting visible cells after filtering

The following code applies filters and selects the top 10 items in column B after some filters are applied to the table. I have been using this for many different filtered selection, but I came across a problem with one of my filter combinations.
I found that when there is only one item in column B after filtering, it doesn't copy that one cell - instead it copies the entire row and seems to be a strange selection.
When I manually add one more item to this filter (total 2), then it copies it fine. Any ideas on why this code won't work when there is only one item?
Sub top10()
Dim r As Range, rC As Range
Dim j As Long
'Drinks top 10
Worksheets("OLD_Master").Columns("A:H").Select
Selection.sort Key1:=Range("H1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Worksheets("OLD_Master").Range("A:H").AutoFilter Field:=4, Criteria1:=Array( _
"CMI*"), Operator:= _
xlFilterValues
Worksheets("OLD_Master").Range("A:H").AutoFilter Field:=5, Criteria1:="Drinks"
Set r = Nothing
Set rC = Nothing
j = 0
Set r = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
For Each rC In r
j = j + 1
If j = 10 Or j = r.Count Then Exit For
Next rC
Range(r(1), rC).SpecialCells(xlCellTypeVisible).Copy
Worksheets("For Slides").Range("P29").PasteSpecial
Worksheets("OLD_Master").ShowAllData
End Sub
Rory helpfully points out:
If you apply Specialcells to only one cell, it actually applies to the entire used range of the sheet.
Now we know what the problem is, we can avoid it! The line of code where you use SpecialCells:
Set r = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
Instead, set the range first, test if it only contains one cell, then proceed...
Set r = Range("B2", Range("B" & Rows.Count).End(xlUp))
' Check if r is only 1 cell
If r.Count = 1 Then
r.Copy
Else ' Your previous code
Set r = r.SpecialCells(xlCellTypeVisible)
For Each rC In r
j = j + 1
If j = 10 Or j = r.Count Then Exit For
Next rC
Range(r(1), rC).SpecialCells(xlCellTypeVisible).Copy
End If
Note, you're assuming there is even one row still visible. It might be that the .End(xlUp) selects row 1 if there is no visible data, you may want to check which row this is first too!
Aside: You really should be fully qualifying your ranges, i.e. instead of
Set r = Range("B2")
You should use
Set r = ThisWorkbook.Sheets("MySheet").Range("B2")
This will save you some confusing errors in future. There are shortcuts you can take, for example saving repetition using With blocks or declaring sheet objects.
' using With blocks
With ThisWorkbook.Sheets("MySheet")
Set r = .Range("B2")
Set s = .Range("B3")
' ...
End With
' Using sheet objects
Dim sh as Worksheet
Set sh = ThisWorkbook.Sheets("MySheet")
Set r = sh.Range("B2")
Thank you to #Rory
Specialcells
Doesn't work with one cell selected. Adapted by doing the following:
......
For Each rC In r
j = j + 1
If j = 10 Or j = r.Count Then Exit For
Next rC
If j = 1 Then
Range(r(1), rC).Copy
Else
Range(r(1), rC).SpecialCells(xlCellTypeVisible).Select
End If
Worksheets("For Slides").Range("P29").PasteSpecial
Worksheets("OLD_Master").ShowAllData
End Sub

VBA: copying the first empty cell in the same row

I am a new user of VBA and am trying to do the following (I got stuck towards the end):
I need to locate the first empty cell across every row from column C to P (3 to 16), take this value, and paste it in the column B of the same row.
What I try to do was:
Find non-empty cells in column C, copy those values into column B.
Then search for empty cells in column B, and try to copy the first non-empty cell in that row.
The first part worked out fine, but I am not too sure how to copy the first non-empty cell in the same row. I think if this can be done, I might not need the first step. Would appreciate any advice/help on this. There is the code:
Private Sub Test()
For j = 3 To 16
For i = 2 To 186313
If Not IsEmpty(Cells(i, j)) Then
Cells(i, j - 1) = Cells(i, j)
End If
sourceCol = 2
'column b has a value of 2
RowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell, copy the first not empty value in that row
For currentRow = 1 To RowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If Not IsEmpty(Cells(i, 3)) Or Not IsEmpty(Cells(i, 4)) Or Not IsEmpty(Cells(i, 5)) Or Not IsEmpty(Cells(i, 6)) Then
Paste
~ got stuck here
Next i
Next j
End Sub
Your loop is really inefficient as it is iterating over millions of cells, most of which don't need looked at. (16-3)*(186313-2)=2,422,043.
I also don't recommend using xlUp or xlDown or xlCellTypeLastCell as these don't always return the results you expect as the meta-data for these cells are created when the file is saved, so any changes you make after the file is saved but before it is re-saved can give you the wrong cells. This can make debugging a nightmare. Instead, I recommend using the Find() method to find the last cell. This is fast and reliable.
Here is how I would probably do it. I'm looping over the minimum amount of cells I can here, which will speed things up.
You may also want to disable the screenupdating property of the application to speed things up and make the whole thing appear more seemless.
Lastly, if you're new to VBA it's good to get in the habit of disabling the enableevents property as well so if you currently have, or add in the future, any event listeners you will not trigger the procedures associated with them to run unnecessarily or even undesirably.
Option Explicit
Private Sub Test()
Dim LastUsed As Range
Dim PasteHere As Range
Dim i As Integer
Application.ScreenUpdating=False
Application.EnableEvents=False
With Range("B:B")
Set PasteHere = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If PasteHere Is Nothing Then Set PasteHere = .Cells(1, 1) Else: Set PasteHere = PasteHere.Offset(1)
End With
For i = 3 To 16
Set LastUsed = Cells(1, i).EntireColumn.Find("*", Cells(1, i), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If Not LastUsed Is Nothing Then
LastUsed.Copy Destination:=PasteHere
Set PasteHere = PasteHere.Offset(1)
End If
Set LastUsed = Nothing
Next
Application.ScreenUpdating=True
Application.EnableEvents=True
End Sub
Sub non_empty()
Dim lstrow As Long
Dim i As Long
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
lstrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For i = 1 To lstrow
If IsEmpty(Range("B" & i)) Then
Range("B" & i).Value = Range("B" & i).End(xlToRight).Value
End If
Next i
End Sub

Consolitate data from multible sheets ,re-arrange the data as per the column name

i want a macro to consolidate the data form multiple sheets to one sheet.. here i given the example ..
Sheet 1
a1:Name b1:Age
a2:sathish b2:22
a3:sarathi b3:24
.
sheet 2
a1:Age b1:Name c1:Dept
a2:60 b2:saran c2:Comp sce
a3:31 b3:rajan c3:B.com
the result should be like this
consolidate sheet
a1:Name b1:Age c1:Dept
a2:sathish b2:22
a3:sarathi b3:24
a4:saran b4:60 c4:Comp sce
a5:rajan b5:31 c5:B.com
Here is the code which i used for consolidate data-
Sub consolidate()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
StartRow = 1
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
shLast = LastRow(sh)
If shLast > 0 And shLast >= StartRow Then
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
I can able consolidate the data but can't re-arrange as per the column title..
Please help me in this ..THanks in advance
First I identify some mistakes and bad practices in your code then I consider how to redesign your macro to achieve your objectives.
Issue 1
The primary purpose of On Error is to allow you to terminate tidily if an unexpected error occurs. You should not use it to avoid errors you expect and you should not ignore errors.
Consider the functions LastRow and LastCol. In both cases, if the Find fails, you ignore the error and carry on. But that means these functions return an incorrect value, so you get another error in the calling routine. If the Find fails you should investigate not ignore. This is true of any other error.
Issue 2
Find returns Nothing if the sheet is empty. You call functions LastRow and LastCol for worksheet "RDBMergeSheet" when it is empty. The code should be:
Set Rng = sh.Cells.Find( ...)
If Rng Is Nothing Then
' Sheet sh is empty
LastRow = 0
Else
LastRow = Rng.Row
End If
Here I have set LastRow to 0 if the worksheet is empty. This ceases to be a side effect of an error but a documented feature of the function: "Return value = 0 means the worksheet is empty." The calling routine must check for this value and skip any empty worksheets. There are other approaches but the key point is: provide code to handle expected or possible errors in a tidy manner. For function LastCol you need LastCol = Rng.Column.
Issue 3
The minimum syntax for a function statement is:
Function Name( ... parameters ...) As ReturnType
The two function statements should end: As Long.
Issue 4
Consider: "ActiveWorkbook.Worksheets("RDBMergeSheet")"
If you are working on multiple workbooks, ActiveWorkbook is not enough. If you are only working on one workbook, ActiveWorkbook is unnecessary. Please do not work with multiple workbooks until your understanding of Excel VBA is better.
Issue 5
You delete worksheet "RDBMergeSheet" and then recreate it which hurts my soul. More importantly, you have lost the column headings. I will discuss this matter further under Redesign.
Replace:
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
with:
Set DestSh = Worksheets("RDBMergeSheet")
With DestSh
.Range(.Cells(2, 1), .Cells(Rows.Count, Columns.Count)).EntireRow.Delete
End With
You use Rows.Count, With and Cells in your code so I will not explain them.
.Range(.Cells(RowTop, ColLeft), .Cells(RowBottom, ColRight)) is an easy method of specifying a range with the top left and bottom right cells.
I have used .EntireRow so I do not need the column numbers. The following gives the same effect:
.Rows("2:" & Rows.Count).EntireRow.Delete
As far as I know ClearContents (which some people favour) has the same effect as Delete. It certainly takes the same number of micro-seconds. For the usages above, both remove any values or formatting from the second row to the last row of the worksheet.
The above change means that row 1 is unchanged and the column widths are not lost. I do not need AutoFit which you have used.
Issue 6
Please be systematic in the naming of your variables. You use StartRow as the first row and shLast as the last row of the source worksheet and Last as the last row of the destination worksheet. Will a colleague who takes over maintenance of your macro find this easy to understand? Will you remember it in six months when this macro needs some maintenance?
Develop a naming system that works for you. Better still, get together with colleagues and agree a single system so all your employer's macros look the same. Document this system for the benefit of future staff. I would name these variables: RowNumDestLast, RowNumSrcStart and RowNumSrcLast. That is: <purpose of variable> <worksheet> <purpose within worksheet>. This system works for me but your system could be completely different. The key feature of a good system is that you can look at your code in a year and immediately know what each statement is doing.
Issue 7
If shLast > 0 And shLast >= StartRow Then
You set StartRow to 1 and never change it so if shLast >= StartRow then shLast > 0. The following is enough:
If shLast >= StartRow Then
Issue 8
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
It is good that you are checking for conditions that will result in fatal errors but is this the most likely error? Even if you are using Excel 2003, you have room for 65,535 people and a heading line. You will break the size limit on a workbook before you exceed the maximum number of rows.
Issue 9
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
This includes the heading row in the range to be copied. Since I will suggest a totally different method later, I will not suggest a correction.
Issue 10
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Why are you pasting the values and formats separately?
Redesign
With the corrections above, the code sort of works. With your source data, it sets the destination sheet to:
Age Name Dept
Name Age
Sathish 22
Sarathi 24
Age Name Dept
60 Saran Comp sce
31 Rajan B.com
This is not what you seek. So the rest of this answer is about design: how do you achieve the appearance you seek? There are many approaches but I offer one and explain why I have picked it without discussing alternatives.
Key issues:
How do you determine which columns to consolidate and in which sequence?
If there is a column in a source worksheet that you are not expecting, what do you do? Is someone collecting information for which there is no central interest or is the column name misspelt?
I have decided to use the existing column names within worksheet "RDBMergeSheet" to determine the sequence. To prepare the macro for a new column name, just add that name to "RDBMergeSheet". If I discover a column name in a source sheet that is not in "RDBMergeSheet", I add it on the right. This second decision will highlight the error if a column name is misspelt but will not be a benefit if someone is collecting extra information in a source worksheet.
I do not copy formats to worksheet "RDBMergeSheet" since, if the source worksheets are formatted differently, each part of worksheet "RDBMergeSheet" would be different.
New statements and explanations
Const RowFirstData As Long = 2
Const WShtDestName As String = "RDBMergeSheet"
A constant means I use the name in the code and can change the value by changing the Const statement.
I assume the first row of every worksheet contains column names and the first data row is 2. I use a constant to make this assumption clear. It would be possible to use this to write code that would handle a different number of heading rows but I have not done so because it would complicate the code for little advantage.
ColNumDestLast = .Cells(1, Columns.Count).End(xlToLeft).Column
.Cells(1, Columns.Count) identifies the last column of row 1 which I assume is blank. .End(xlToLeft) is the VBA equivalent of the keyboard Ctrl+Left. If .Cells(1, Columns.Count) is blank, .Cells(1, Columns.Count).End(xlToLeft) returns the first cell to the left which is not blank. .Column gives the column number of that cell. That is, this statement sets ColNumDestStart to the column number of the last cell in row 1 with a value.
ColHeadDest = .Range(.Cells(1, 1), .Cells(1, ColNumDestLast)).Value
This copies the values from row 1 to the variant array ColHeadDest. ColHeadDest will be redimensioned by this statement to (1 to 1, 1 to ColNumDestLast). The first dimension is for the rows, of which there is only one, and the second dimension is for the columns.
Replacement consolidate
I hope I have added enought comments for the code to make sense. You still need the corrected LastRow and LastCol. I could have replaced LastRow and LastCol but I think I have provided enough new code to be getting on with.
Option Explicit
Sub consolidate()
Dim ColHeadCrnt As String
Dim ColHeadDest() As Variant
Dim ColNumDestCrnt As Long
Dim ColNumDestLast As Long
Dim ColNumSrcCrnt As Long
Dim ColNumSrcLast As Long
Dim Found As Boolean
Dim RowNumDestCrnt As Long
Dim RowNumDestStart As Long
Dim RowNumSrcCrnt As Long
Dim RowNumSrcLast As Long
Dim WShtDest As Worksheet
Dim WShtSrc As Worksheet
Dim WShtSrcData() As Variant
Const RowNumFirstData As Long = 2
Const WShtDestName As String = "RDBMergeSheet"
'With Application
' .ScreenUpdating = False ' Don't use these
' .EnableEvents = False ' during development
'End With
Set WShtDest = Worksheets(WShtDestName)
With WShtDest
' Clear existing data and load column headings to ColHeadDest
.Rows("2:" & Rows.Count).EntireRow.Delete
ColNumDestLast = .Cells(1, Columns.Count).End(xlToLeft).Column
ColHeadDest = .Range(.Cells(1, 1), _
.Cells(1, ColNumDestLast)).Value
End With
' Used during development to check array loaded correctly
'For ColNumDestCrnt = 1 To ColNumDestLast
' Debug.Print ColHeadDest(1, ColNumDestCrnt)
'Next
RowNumDestStart = RowNumFirstData ' Start for first source worksheet
For Each WShtSrc In Worksheets
ColNumSrcLast = LastCol(WShtSrc)
RowNumSrcLast = LastRow(WShtSrc)
If WShtSrc.Name <> WShtDestName And _
RowNumSrcLast <> 0 Then
' Source sheet is not destination sheet and it is not empty.
With WShtSrc
' Load entire worksheet to array
WShtSrcData = .Range(.Cells(1, 1), _
.Cells(RowNumSrcLast, ColNumSrcLast)).Value
End With
With WShtDest
For ColNumSrcCrnt = 1 To ColNumSrcLast
' For each column in source worksheet
Found = False
ColHeadCrnt = WShtSrcData(1, ColNumSrcCrnt)
' Find matching column in destination worksheet
For ColNumDestCrnt = 1 To ColNumDestLast
If ColHeadCrnt = ColHeadDest(1, ColNumDestCrnt) Then
Found = True
Exit For
End If
Next ColNumDestCrnt
If Not Found Then
' Current source column's name is not present in the
' destination sheet Add new column name to array and
' destination worksheet
ColNumDestLast = ColNumDestLast + 1
ReDim Preserve ColHeadDest(1 To 1, 1 To ColNumDestLast)
ColNumDestCrnt = ColNumDestLast
With .Cells(1, ColNumDestCrnt)
.Value = ColHeadCrnt
.Font.Color = RGB(255, 0, 0)
End With
ColHeadDest(1, ColNumDestCrnt) = ColHeadCrnt
End If
' I could extract data from WShtSrcData to another array
' suitable for downloading to a column of a worksheet but
' it is easier to move the data directly to the worksheet.
' Also, athought downloading via an array is marginally
' faster than direct access, loading the array will reduce,
' and perhaps eliminate, the time benefit of using an array.
RowNumDestCrnt = RowNumDestStart
For RowNumSrcCrnt = RowNumFirstData To RowNumSrcLast
' Copy value from array of source data to destination sheet
.Cells(RowNumDestCrnt, ColNumDestCrnt) = _
WShtSrcData(RowNumSrcCrnt, ColNumSrcCrnt)
RowNumDestCrnt = RowNumDestCrnt + 1
Next
Next ColNumSrcCrnt
End With ' WShtDest
' Adjust RowNumDestStart ready for next source worksheet
RowNumDestStart = RowNumDestStart + RowNumSrcLast - RowNumFirstData + 1
End If ' Not destination sheet and not empty source sheet
Next WShtSrc
With WShtDest
' Leave workbook with destination worksheet visible
.Activate
End With
'With Application
' .ScreenUpdating = True
' .EnableEvents = True
'End With
End Sub