I have written a code which gives me exact count of empty/blank cells in a column/s.
This shows the results if I run the code for column A
Sub countblank()
Const column_to_test = 2 'column (B)
Dim r As Range
Set r = Range(Cells(2, column_to_test), Cells(Rows.Count,
column_to_test).End(xlUp))
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & " Rows
with blank cells in column B")
Const columns_to_test = 3 'column (C)
Set r = Range(Cells(3, columns_to_test), Cells(Rows.Count,
columns_to_test).End(xlUp))
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & " Rows
with blank cells in column c ")
'and so on i can count the blanks for as many columns i want
End Sub
But the problems are as follows:-
If there are no blanks, this macro will throw an error and will terminate itself. What if I want to run the remaining code?
Using array or something equivalent I want to search the multiple columns by header at the same time, instead of column number that to separately as shown in the code.
If a blank/s is found it pops a Msgbox but can we get the list of error in a separate new sheet called "error_sheet"?
Function getBlanksInListCount(ws As Worksheet, Optional FirstRow = 2, Optional TestColumn = 2)
With ws
getBlanksInListCount = WorksheetFunction.countblank(.Range(.Cells(FirstRow, TestColumn), .Cells(.Rows.Count, TestColumn).End(xlUp)))
End With
End Function
Try this
Sub countblank()
Dim i As Long
For i = 2 To 10 ' for looping through the columns
Dim r As Range
Set r = Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
'for not getting error and adding error messages in the error_sheet
'MsgBox ("There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column)
Sheets("error_sheet").Range(r.Address).Value = "There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column
Next i
End Sub
Try sub MAIN to examine the first three columns:
Sub countblank(column_to_test As Long)
Dim r As Range, rr As Range, col As String
col = Split(Cells(1, column_to_test).Address, "$")(1)
Set r = Range(Cells(2, column_to_test), Cells(Rows.Count, column_to_test).End(xlUp))
On Error Resume Next
Set rr = r.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rr Is Nothing Then
MsgBox ("There are no Rows with blank cells in column " & col)
Else
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & " Rows with blank cells in column " & col)
End If
End Sub
Sub MAIN()
Dim i As Long
For i = 1 To 3
Call countblank(i)
Next i
End Sub
Q1 can be answered by using an error handling statement. Error handling statements can be as simple or complicated as one would like them to be. The one below is probably my first go to method.
' if no blank cells found, code continues
On Error Resume Next
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & _
" Rows with blank cells in column B")
Using headers would work fine. Please see final answer below for this method.
This answer is a minor change from the answer submitted by Imran Malek
Sub countblank()
Dim i As Long
' new integer "row" declared
Dim row As Integer
' new integer "row" set
row = 1
For i = 2 To 4 ' for looping through the columns
Dim r As Range
Set r = Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
'for not getting error and adding error messages in the error_sheet
'MsgBox ("There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column)
' using the value in row to insert our output
Sheets("error_sheet").Range("A" & row).Value = "There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column
' adding 1 to "row" to prep for next output
row = row + 1
Next i
End Sub
Final answer: My apologies for the lengthy answer. This answer is a modification of Imran Malek's answer, found in the link of answer 3. Please note, this version does not contain error handling, explained in Q1.
Sub countblank()
Dim Header(1 To 4) As String
Header(1) = "Name"
Header(2) = "Age"
Header(3) = "Salary"
Header(4) = "Test"
Dim i As Integer
Dim row As Integer
Dim r As Range
Dim c As Integer
row = 1
' **NOTE** if you add any more values to {Header}, the loop has to be equal to the Header count
' i.e. 4 {Headers}, 4 in the loop
For i = 1 To 4
'looking for the header in row 1
c = Cells(1, 1).EntireRow.Find(What:=Header(i), LookIn:=xlValues).Column
'defining the column after header is found
Set r = Range(Cells(2, c), Cells(Rows.Count, c).End(xlUp))
' using the value in row to insert our output
Sheets("error_sheet").Range("A" & row).Value = "There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column
' adding 1 to "row" to prep for next output
row = row + 1
Next i
End Sub
I am trying randomly generate a whole number between 1 and 100, whether that be in a cell or in the vba code directly. Then I want to use that value as the lookup value for a VLookup that will pull another randomly generated whole number between 1 and 10 from a different sheet. Then I want to use that second number between 1 and 10 as an indicator to fill in that many cells in a column with the first number between 1 and 100.
So for example if I were doing it manually: I would have in cell "C27" on Sheet1 =MROUND(RANDBETWEEN(1,100),1). Let's say it returns 40. Then I would look on Sheet2 for number 40 in column A, look over to Column D where there is another =MROUND(RANDBETWEEN(1,10),1). Let's say that one returns 5 (so I need to fill in 5 cells of a column). Then I would head back to Sheet1 and enter 40 into cells K31 through K35 (the original random whole number).
I'm aware that RAND and RANDBETWEEN update anytime the worksheet recalculates. I use triggered IF statements to keep them from updating unless I change a value in a trigger cell. If generating a random number with VBA makes that even easier, I'm all for it.
I don't think it will be helpful for me to post the many iterations I've attempted as I've tried to apply solutions to each individual task of this macro. None of them have seemingly even gotten me close. But here's what I'm using right now that's also not even close. This code was for me to try and get it to work period. So the numbers are static and not random. But I need them random. And yes, this is for me to generate random monsters for my D&D game mastering :)
Thanks to anyone who might be able to get me on the right track!
Sub MonsterRoll()
'
' MonsterRoll
Dim ws As Worksheet
Dim roll As Integer
Dim No1 As Integer
Dim No2 As Integer
Set ws = Sheets("Combat Helper")
roll = 5
No1 = 31
No2 = 31 + 5
On Error Resume Next
For i = No1 To No2
area.Cells(i, 11).Value = 5
Next
End Sub
This table houses the vlookups into sheet "Encounters"
This table contains the source data, with column D being a RANDBETWEEN
I'm still not sure about a few cell references, but think I have a general idea. The code below can be a starting point to do most of what you want -- with a few warnings...
Since you are monitoring for changes in Sheet1 cells K31:K50, and then making changes to that same range, that will trigger the change event again. So, to avoid crazy results, I added a flag so that it will ignore changes untill you tell it to stop ignoring. That will be when you have finished all processing for your original change.
Personally, I would prefer to generate my own random numbers via code for the simple reason that ANY change to any cell will trigger all of your 'random' numbers to regenerate.
Go to Function 'Set_All_Cell_Values' and add whatever code you need to fill other cells.
Option Explicit
Dim blnIgnoreChanges As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Integer
Dim iYourNbr As Integer
Dim iMyNbr As Integer
Dim iRow As Integer
Dim iHowMany As Integer
Dim Why As String
' The following code can be dangerous if your code is not working properly!!!!
' Since you want to 'monitor' changes to K31:K50, and then change those same cells via code,
' which will in turn trigger this 'Worksheet_Change' subroutine to fire again,
' you need to be able to ignore changes on demand.
' If this flag gets set and your code didn't complete (AND turn the flag off), then
' any monitoring of future changes will be ignored!!
' If the flag fails to get reset, then just execute the following code in the immediate window:
' blnIgnoreChanges = false
If blnIgnoreChanges = True Then
Exit Sub
End If
Set ws1 = ThisWorkbook.Worksheets("Combat Helper")
Set ws2 = ThisWorkbook.Worksheets("Encounters")
' Sample data in Sheet2
' A B C D E F G H I J
'40 Bird, Falcon 1 1 1 -10 5 2 1d4 t
'41 Men: Wild Man 2 3 2 -9 2 3 1d5 u
'42 Beast 3 5 3 -8 3 4 1d6 v
'43 Elephant 4 7 4 -7 4 5 1d7 w
' Monitor only cells K31:K50
If Target.Row >= 31 And Target.Row <= 50 And Target.Column = 11 Then
' Value must be between 1 and 100
If Target.Value < 1 Or Target.Value > 100 Then
MsgBox "Must enter between 1 and 100"
Exit Sub
Else
' If you want to Lookup match in Col A of Sheet2, and then get value from col D.
iYourNbr = Application.VLookup(Target.Value, ws2.Range("A3:N102"), 4, False)
' I prefer to Generate my own random number between 1 and 10
iMyNbr = Int((10 - 1 + 1) * Rnd + 1)
iRow = Find_Matching_Value(Target.Value)
Debug.Print "Matching Row in Sheet2 is: " & iRow
' DANGER!! If you execute the following line of code, then you MUST set to FALSE
' when you have finished one change!!!
blnIgnoreChanges = True
iHowMany = Sheet2.Cells(iRow, 4).Value
Sheet1.Cells(Target.Row, 13) = iHowMany
Set_All_Cell_Values Target.Row, iRow, iHowMany
End If
' We can ignore all other cell changes
Else
'Debug.Print "Change made to: " & "R" & Target.Row & ":C" & Target.Column & " but not my row or column! Value is:" & Target.Value
End If
End Sub
Function Set_All_Cell_Values(iS1Row As Integer, iS2Row As Integer, iHowMany As Integer)
Dim i As Integer
Debug.Print "Add code to set cells for Sheet1 R:" & iS1Row & " Sheet2 R:" & iS2Row
For i = iS1Row + 1 To iS1Row + iHowMany - 1
Sheet1.Cells(i, 11) = Sheet1.Cells(iS1Row, 11)
'#################################################
' ADD CODE TO FILL OTHER CELLS as needed!!!
'#################################################
Next i
blnIgnoreChanges = False
End Function
Function Find_Matching_Value(iFind As Integer) As Integer
Dim Rng As Range
If Trim(iFind) <> "" Then
With Sheets("Encounters").Range("A:A")
Set Rng = .Find(What:=iFind, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Find_Matching_Value = Rng.Row
Else
MsgBox "Did not find match for value: " & iFind
End If
End With
Else
MsgBox "You passed an empty value to 'Find_Matching_Value'"
End If
End Function
I'm trying to make a function to do the following:
Cycle through all my datasets in my sheet
Cycle through each column in my datasets
Look at the title for that column and check if it is in my list.
Find find a few various other columns, but this time using .Find
Now cycle through each row in the column for that specific dataset
Use the column references found in point 4 and the row from point 5 to put the cell's into a variable that will be used on step 7 which is to insert a formatted comment in the originally found column (for that row).
I've tried getting some code working from what I found on a different site but I can't get it working correct, I'm stuck at part 5.
A data example could look like:
My attempted code looks like:
Sub ComTest()
COMLIST = ";Cond;"
Set rng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
For Each a In rng.SpecialCells(xlCellTypeConstants).Areas
With a.CurrentRegion
Set r = .Rows(1)
For j = 1 To r.Columns.Count
TitleCell = r.Cells(j).Address
v = ";" & Range(TitleCell).Value & ";"
'-----------------------------------------------------------------------------------------
If InStr(1, COMLIST, v) Then
On Error Resume Next
xRange = .Offset(1).Resize(.Rows.Count - 1).Columns(j).Address
For i = 1 To UBound(xRange)
v = b.Value
Next i
Condw = r.Columns.Find(Replace(v, ";", "") & " " & "w", lookAt:=xlWhole).Column
Condw = .Cells(r, Condw).Address
' Add more stuff here
End If
'-----------------------------------------------------------------------------------------
Next j
End With
Next a
End Sub
As for part 7, the output would essentially be as follows for "row 1" but this part I should be able to do, it's the looping part that I am struggling with.
This question raises a few points that this answer might resolve for you and others in the future:
I note that not many of your previous questions have accepted answers, and that several of them present answers but you have needed to respond by saying it doesn't suit your needs for a certain reason. It suggests you aren't really providing the right details in your question. I think that's the case here. Perhaps you could outline the outcome you are trying to achieve and, especially for Excel VBA, the precise structure of your spreadsheet data. It's tempting to think in this question that you simply want to know how to take the values of Columns C to F and write them to a comment in Column B for any row that contains data.
Using web code can often take more time to understand and adapt than learning the code syntax from first principles. Your provided code is difficult to follow and some parts seem odd. I wonder, for example, what this snippet is meant to do:
xRange = .Offset(1).Resize(.Rows.Count - 1).Columns(j).Address
For i = 1 To UBound(xRange)
v = b.Value
Next i
Using Option Explicit at the top of your module (which forces you to declare your variables) makes VBA coding and debugging much easier, and code submitted on SO is easier to follow if we can see what data types you meant variables to hold.
If your question is merely "How do I take the values of Columns C to F and write them to the cell in Column B for any row that contains data?", then your code could be as simple as:
Dim condCol As Range
Dim cell As Range
Dim line1 As String
Dim line2 As String
Dim cmt As Comment
'Define the "Cond" column range
'Note: this is an unreliable method but we'll use it here for the sake of brevity
Set condCol = ThisWorkbook.Worksheets("Sheet1").UsedRange.Columns("B")
'Delete any comment boxes
condCol.ClearComments
'Loop through the cells in the column and process the data if it's a number
For Each cell In condCol.Rows
If Not IsEmpty(cell.Value) And IsNumeric(cell.Value) Then
'Acquire the comment data
line1 = "Cond: " & cell.Offset(, 1).Value & "/" & cell.Offset(, 2).Value & _
" (" & Format(cell.Offset(, 3), "0.00%") & ")"
line2 = "Cond pl: $" & cell.Offset(, 4).Value
Set cmt = cell.AddComment(line1 & vbCrLf & line2)
'Format the shape
With cmt.Shape.TextFrame
.Characters(1, 5).Font.Bold = True
.Characters(Len(line1 & vbCrLf), 8).Font.Bold = True
.AutoSize = True
End With
End If
Next
If, on the other hand, your question is that you have unreliable data on your spreadsheet and your only certainty is that the headings exist on any one row, then some form of search routine must be added. In that case your code could look like this:
Dim rng As Range
Dim rowRng As Range
Dim cell As Range
Dim condCol(0 To 4) As Long
Dim line1 As String
Dim line2 As String
Dim allHdgsFound As Boolean
Dim i As Integer
Dim cmt As Comment
Set rng = ThisWorkbook.Worksheets("Sheet1").UsedRange
rng.ClearComments
For Each rowRng In rng.Rows
If Not allHdgsFound Then
'If we haven't found the headings,
'loop through the row cells to try and find them
For Each cell In rowRng.Cells
Select Case cell.Value
Case Is = "Cond": condCol(0) = cell.Column
Case Is = "Cond w": condCol(1) = cell.Column
Case Is = "Cond r": condCol(2) = cell.Column
Case Is = "Cond %": condCol(3) = cell.Column
Case Is = "Cond wpl": condCol(4) = cell.Column
End Select
Next
'Check if we have all the headings
'by verifying the condCol array has no 0s
allHdgsFound = True
For i = 0 To 4
If condCol(i) = 0 Then
allHdgsFound = False
Exit For
End If
Next
Else
If Not IsEmpty(rowRng.Cells(1).Value) Then
'The cell has values so populate the comment strings
line1 = "Cond: " & rowRng.Columns(condCol(1)).Value & "/" & _
rowRng.Columns(condCol(2)).Value & _
" (" & Format(rowRng.Columns(condCol(3)).Value, "0.00%") & ")"
line2 = "Cond pl: $" & rowRng.Columns(condCol(4))
Set cmt = rowRng.Columns(condCol(0)).AddComment(line1 & vbCrLf & line2)
'Format the shape
With cmt.Shape.TextFrame
.Characters(1, 5).Font.Bold = True
.Characters(Len(line1 & vbCrLf), 8).Font.Bold = True
.AutoSize = True
End With
Else
'We've reached a blank cell so re-set the found values
allHdgsFound = False
Erase condCol
End If
End If
Next
Of course your data might be structured in any number of other ways, but we don't know that. My point is that if you can be more specific in your question and provide an outcome you are trying to achieve, you are likely to receive answers that are more useful to you.
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
I have a list of companies and each has a scope of work, address and phone number. Some of the companies have multiple scopes of work. It looks something like this:
I want to get rid of the second copy of the stuff like the address (and in my case phone numbers and such) while copying the unique data in the second line and putting it in the first line and then getting rid of the second line.
I have very little experience of coding. I looked up how to do this step by step but something is wrong within the code or the syntax:
I found code for going down a column for a blank space.
I looked up how I would copy a cell to the right of the active blank cell.
I found code for merging the info into the cell one above and one to the right of the active cell.
I found code that deletes the row with the active cell.
I want it to loop until there are no more blank company cells.
So this is how I put it together:
Public Sub SelectFirstBlankCell()
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
Do
sourceCol = 6 'column F has a value of 6
rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell and select it
For currentRow = 1 To rowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
Cells(currentRow, sourceCol).Select
End If
Next
Loop Until A647
End Sub
.
Sub mergeIt()
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(1, 1)).Merge
ActiveCell.Select
End Sub
.
Sub DeleteRow()
RowNo = ActiveCell.Row
If RowNo < 7 Then Exit Sub
Range("A" & ActiveCell.Row).EntireRow.Delete
Sheets("Summary").Select
Range("A4:O4").Select
Selection.Copy
LastRow = Range("A65536").End(xlUp).Offset(1, 0).Row
End Sub
Please never post code as an image since someone who wants to try it out must type it. You can edit your question and add a new section including revised code if necessary.
My copy of your code (plus line numbers) is:
1 Public Sub SelectFirstBlankCell()
2 Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
3 Dim currentRowValue As String
4 sourceCol = 1 'column F has a value of 6
5 rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
6 'for every row, find the first blank cell and select it
7 For currentRow = 1 To rowCount
8 currentRowValue = Cells(currentRow, sourceCol).Value
9 If IsEmpty(currentRowValue) Or currentRowValue = "" Then
10 Cells(currentRow, sourceCol).Select
11 End If
12 Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(1, 1)).Merge
13 ActiveCell.Select
14 If IsEmpty(currentRowValue) Or currentRowValue = "" Then
15 Cells(Range("sourceCol:21")).Delete
16 End If
17 Next
18 End Sub
I am sure we all started selecting cells and accessing the ActiveCell because the macro recorder does this. However, selecting cells is slow and it is very easy to lose track of what is selected. I believe this is your main problem.
Problem 1 The end value for a For-Loop is fixed at the start; Any attempt to reduce rowCount when you delete something will have no effect on the For-Loop.
Problem 2 I suspect you mean the range in line 15 to be sourceCol & ":" & currentRow.
Problem 3 In line 10 you select a cell if it is blank. In line 12 you merge the active cell whether or not you have just selected it. This means your code attempts a merge for every row.
Problem 4 Column 1 is the column that might be blank. Suppose row 1000 is the last row with a supplier's name but row 1005 is the last row with a product. Your code would not process rows 1001 to 1005.
Problem 5 Function IsEmpty() only returns sensible values for Variants. A Variant is either a cell or a variable that can hold different types of value.
I have not tried your code so there may be more mistakes. Do get dispirited. To the best of my knowledge, problem 1 is not documented. I had to discover this "feature" for myself by attempting code similar to yours. The specification for Function IsEmpty() states its limitations but, unless you fully understand Variants, the significance is not obvious. The other problems are easy errors to make and only practice will reduce their frequency.
Below is my solution to your problem. It is not how I would code it for myself but I think I have introduced enough new concepts for one solution.
I do not say much about the syntax of the VBA statements I use since it is usually easy to look up a statement once you know it exists. Ask if necessary but please try to understand the code before asking.
I do not like deleting in situ; it is slow and, if your code is faulty, you have to load the previous version of the worksheet and start again. I have a source (Src) and a Destination (Dest) worksheet.
I use constants for values that might change but not during a single run of your macro.
You assume the address and other details for Jan's Supply on rows 2 and 3 match. I am paranoid and never make assumptions like this. If my code would discard important information if rows 2 and 3 did not match, I check they match. I also allow for rows like this because I have encountered them:
John's supply Cookies 555 Main Street CA
Cakes Littleville CA
This will become:
John's supply Cookies & Cakes 555 Main Street Littleville CA
Some of the comments explain my choice of VBA statement but most do not. When you have to update a macro you wrote 12 months ago for new requirements, the few minutes you spent adding comments can save you hours finding your way around the code.
You may not like my system of naming variables. Fine; develop your own. When you return to this macro in 12 months, an immediate understanding of the variables will save more time.
Option Explicit
Const WkshtSrcName As String = "Sheet1" ' \ Replace "Sheet1" and "Sheet2"
Const WkshtDestName As String = "Sheet2" ' / with the names of your worksheets
Const ColSupplier As String = "A" ' \ In Cells(R, C), C can be a
Const ColProduct As String = "B" ' / number or a column identifier
Const RowDataFirst As Long = 1
Sub MergeRowsForSameSupplier()
Dim ColCrnt As Long ' \ Columns in source and destination are the
Dim ColMax As Long ' / same so single variables are adequate.
Dim RowDestCrnt As Long ' \ Rows in source and destination
Dim RowSrcCrnt As Long ' | worksheets are different
Dim RowSrcMax As Long ' / so need separate variables.
Dim ProductCrnt As String
Dim Join As String
Dim SupplierCrnt As String
Dim WkshtSrc As Worksheet
Dim WkshtDest As Worksheet
Set WkshtSrc = Worksheets(WkshtSrcName)
Set WkshtDest = Worksheets(WkshtDestName)
With WkshtSrc
' I consider this to be the easiest technique of identifying the last used
' row and column in a worksheet. Note: the used range includes trailing
' rows and columns that are formatted but otherwise unused or were used but
' aren't now so other techniques can better match what the user or the
' programmer usually mean by "used".
ColMax = .UsedRange.Columns.Count
RowSrcMax = .UsedRange.Rows.Count
End With
With WkshtDest
.Cells.EntireRow.Delete ' Delete any existing contents
End With
RowDestCrnt = RowDataFirst
For RowSrcCrnt = RowDataFirst To RowSrcMax
With WkshtSrc
SupplierCrnt = .Cells(RowSrcCrnt, ColSupplier).Value
ProductCrnt = .Cells(RowSrcCrnt, ColProduct).Value
End With
If SupplierCrnt <> "" Then
' This is the first or only row for a supplier.
' Copy it to Destination worksheet.
With WkshtSrc
.Range(.Cells(RowSrcCrnt, 1), .Cells(RowSrcCrnt, ColMax)).Copy _
Destination:=WkshtDest.Cells(RowDestCrnt, 1)
End With
RowDestCrnt = RowDestCrnt + 1
ElseIf ProductCrnt = "" Then
' Both Supplier and Product cells are empty.
With WkshtSrc
If .Cells(RowSrcCrnt, Columns.Count).End(xlToLeft).Column = 1 And _
.Cells(RowSrcCrnt, 1).Value = "" And _
.Cells(RowSrcCrnt, Columns.Count).Value = "" Then
' If you do not understand why I have so many tests,
' experiment with Ctrl+Left
' Row empty so ignore it
Else
' Don't know what to do with this error so give up
Call MsgBox("Cells " & ColSupplier & RowSrcCrnt & " and " & _
ColProduct & RowSrcCrnt & " of worksheet " & _
WkshtSrcName & _
" are blank but the entire row is not blank", _
vbOKOnly + vbCritical, "Merge rows for same supplier")
Exit Sub
End If
End With
Else
' Supplier cell is empty. Product cell is not.
' Row RowDestCrnt-1 of the Destination worksheet contains the first row
' for this supplier or the result of merging previous rows for this
' supplier.
If WkshtSrc.Cells(RowSrcCrnt + 1, ColSupplier).Value = "" And _
WkshtSrc.Cells(RowSrcCrnt + 1, ColProduct).Value <> "" Then
' The next row is for the same supplier but is not a blank row
Join = ","
Else
' This is last row for this supplier
Join = " &"
End If
' Add to list of products
With WkshtDest
.Cells(RowDestCrnt - 1, ColProduct).Value = _
.Cells(RowDestCrnt - 1, ColProduct).Value & Join & " " & _
ProductCrnt
End With
For ColCrnt = 1 To ColMax
If ColCrnt = Cells(1, ColSupplier).Column Or _
ColCrnt = Cells(1, ColProduct).Column Then
' You may think (and you may be right) that the supplier and product
' will always be in the first two columns. But have seen the
' weirdest arrangements and make no assumptions
' Ignore this column
Else
If WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Value = "" Then
' The most likely arrangement: the subsequent row has no
' value in this column. Nothing to do.
ElseIf WkshtDest.Cells(RowDestCrnt - 1, ColCrnt).Value = "" Then
' This source row has a value in this column but [the] previous
' row[s] did not.
' Note: I use the copy statement because it copies formatting as
' well as the value which may be useful.
WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Copy _
Destination:=WkshtDest.Cells(RowDestCrnt - 1, ColCrnt)
ElseIf WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Value = _
WkshtDest.Cells(RowDestCrnt - 1, ColCrnt).Value Then
' Values match. Nothing to do.
Else
' Values do not match.
' Don't know what to do with this error so give up.
Call MsgBox("The value in cell " & ColNumToCode(ColCrnt) & _
RowSrcCrnt & " of worksheet " & WkshtSrcName & _
" does not match a value in an earlier row " & _
"for the same supplier", _
vbOKOnly + vbCritical, "Merge rows for same supplier")
Exit Sub
End If
End If
Next
End If
Next
With WkshtDest
.Cells.Columns.AutoFit
End With
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
' Convert a column identifier (A, AA, etc.) to its number
Dim Code As String
Dim PartNum As Long
' Last updated 3 Feb 12. Adapted to handle three character codes.
If ColNum = 0 Then
ColNumToCode = "0"
Else
Code = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
Code = Chr(65 + PartNum) & Code
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = Code
End Function