This works Lastrow = 8, but not 9 (Type mismatch)
If i remove If Not (myarray = Empty) Then it does not work for 8
What is the easiest way to solve this?
Public Function GetRowToWriteOn(ByVal SheetName As String, ByVal idnr As Integer) As Integer
LastRow = (Sheets(SheetName).UsedRange.Rows.Count) + 1
MsgBox (LastRow)
myarray = Sheets(SheetName).Range("d8:d" & LastRow).Value
If Not (myarray = Empty) Then
For row = 1 To UBound(myarray, 1)
If (myarray(row, 1) = idnr) Then
GetRowToWriteOn = row
Exit Function
End If
Next
End If
GetRowToWriteOn = LastRow
Exit Function
End Function
MyArray is taking 2 different types, depending on the range given.
If you are looking at 1 cell, then it is a single variant (which can be tested if it is Empty)
If you are looking at 2 or more cells, then it becomes an array of variant, so you would have to test each cell.
myarray = Sheets(SheetName).Range("d8:d8").Value - myarray gets the value in d8
myarray = Sheets(SheetName).Range("d8:d9").Value - myarray(1,1) gets the value in d8, and myarray(2,1) gets the value in d9
to test, use:
if vartype(myarray)=vbArray then
' run through the array
else
' do single value stuff
endif
I feel like your code should look more like this
Option Explicit
Public Function GetRowToWriteOn(ByVal SheetName As String, ByVal idnr As Integer) As Integer
Dim lastrow As Long, row As Long
lastrow = (Sheets(SheetName).UsedRange.Rows.Count) + 1
MsgBox (lastrow)
Dim myarray() As Variant
myarray = Sheets(SheetName).Range("d8:d" & lastrow).Value
If Not (IsEmpty(myarray)) Then
For row = 1 To UBound(myarray, 1)
If (myarray(row, 1) = idnr) Then
GetRowToWriteOn = row
Exit Function
End If
Next
End If
GetRowToWriteOn = lastrow
Exit Function
End Function
BUT I also think there is another way to do what you want. A little simpler and used built in functions. I think I captured your intention here:
Dim RowToWriteOn As Long, SheetName As String, lastRow As Long
Dim rng As Range
SheetName = "Sheet1"
lastRow = (Sheets(SheetName).UsedRange.Rows.Count) + 1
Set rng = Sheets(SheetName).Range("d" & lastRow)
RowToWriteOn = rng.End(xlUp).row
Public Function GetRowToWriteOn(ByVal SheetName As String, _
ByVal idnr As Integer) As Long
Dim lastRow As Long, f As Range
lastRow = Sheets(SheetName).Cells(Rows.Count, 4).End(xlUp).Row
Set f = Sheets(SheetName).Range("D8:D" & lastRow).Find(what:=idnr, _
lookat:=xlWhole)
If Not f Is Nothing Then
GetRowToWriteOn = f.Row
Else
GetRowToWriteOn = lastRow + 1
End If
End Function
myarray = Sheets(SheetName).Range("d8:d" & LastRow)
(without value)...
And you can use: if ubound(myArray) > 1 then ;..
I think it could be as easy as this, no...?
Related
I have the following requirement I have 2 columns with unique keys called code. In one column below the code, there are one or multiple values present which is the answer. Like in below format
A X
1
2
B Y
9
3
Now the code will have a value populated in next column, while answers wont.
Now I have to find answers for all codes like A, B, C etc. For e.g If I compare with A then answer should be 1,2. I was writing a small subroutine as a beginning but I am facing issues. Can you please correct it
Sub CalculateCellValue()
Dim ValuesBelow As Variant
Dim ValuesRight As String
Dim rows1 As Integer
rows1 = 4
Dim colC As Integer
colC = 2
ValuesRight = ActiveSheet.Cells(rows1 + 1, colC + 1)
While (Not IsEmpty(ValuesRight))
ValuesBelow = ActiveSheet.Cells(rows1 + 1, colC)
rows1 = rows1 + 1
ValuesRight = ActiveSheet.Cells(rows1 + 1, colC + 1)
Wend
MsgBox (ValuesBelow)
End Sub
Purely for an ordered example as shown:
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet5") 'Change as appropriate
Dim myArr()
myArr = ws.Range("A1:B" & GetLastRow(ws, 1)).Value
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(myArr, 1) To UBound(myArr, 1)
If myArr(i, 2) <> vbNullString Then
If Not dict.exists(myArr(i, 1)) Then
Dim currKey As String
currKey = myArr(i, 1)
dict.Add myArr(i, 1), vbNullString
End If
Else
dict(currKey) = dict(currKey) & ", " & myArr(i, 1)
End If
Next i
Dim key As Variant
For Each key In dict
MsgBox key & " = " & Right$(dict(key), Len(dict(key)) - 1)
Next key
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
I used below code to match my requirement
Function findBelowAll(rows1 As Long)
Dim ValuesBelow() As Variant
ReDim ValuesBelow(1 To 1) As Variant
Dim ValuesRight As Variant
Dim colC As Long
colC = 1
Dim i As Long
ValuesRight = ""
While (ValuesRight = "")
rows1 = rows1 + 1
' change / adjust the size of array
ReDim Preserve ValuesBelow(1 To UBound(ValuesBelow) + 1) As Variant
' add value on the end of the array
ValuesBelow(UBound(ValuesBelow)) =
Worksheets(ActiveSheet.Name).Cells(rows1, colC).Value
ValuesRight = Worksheets(ActiveSheet.Name).Cells(rows1, 2).Value
Wend
For i = LBound(ValuesBelow) To UBound(ValuesBelow) - 1
findBelowAll = findBelowAll & ValuesBelow(i) & vbNewLine
Next i
End Function
I am trying to exit the function if either the value is equal to the value I'm looking for, or if the row is equal to the row I'm looking for.
But every time I use Exit Function, it doesn't work. And if I replace it with End Function it tells me that I don't have an End to my If statement. And I'm getting lost.
Function recursion(whereItEnds As Integer, lookingFor As Variant, currentMarker As Range, I As Integer, wsEverything As Worksheet) As Integer
Dim col As Integer
Dim newMarker As String
newMarker = currentMarker.Value
Dim currentMarker1 As Range
recursion = 2
col = 2
If (StrComp(lookingFor, newMarker, vbTextCompare) = 0) Then
Exit Function
End If
While (IsEmpty(wsEverything.Cells(col, "B").Value) = False)
If (StrComp(wsEverything.Cells(col, "B").Value, newMarker, vbTextCompare) = 0) Then
wsEverything.Cells.Range("A" & col, "F" & col).Copy
Worksheets("Review").Cells.Range("A" & I).PasteSpecial
Worksheets("Review").Cells.Range("G" & I).Value = col
I = I + 1
Set currentMarker1 = wsEverything.Cells(col, "E")
If (col = whereItEnds) Then
Exit Function
End If
recursion = recursion(whereItEnds, lookingFor, currentMarker1, I, wsEverything)
End If
col = col + 1
Wend
End Function
I'm almost completely out of ideas as to why neither works.
EDIT: It hits the if statements, it goes into those codes. but when debugging, it touches "exit function" but then it just keeps going. i just want it to end the statement. This is pulling data off another long sheet and putting it on a second sheet. it is checking for child parent circular errors. where a parent in the future is dependent on the child that originally was dependent on it.
Is this what you want?
Before (Sheet1):
After (Review Sheet):
Option Explicit
Public Sub TestRecursion()
Dim result As Variant, ws As Worksheet
Set ws = Sheet1
result = Recursion(ws.Cells(2, 8), ws.Cells(2, 2), ws.Cells(2, 5), 2, ws)
End Sub
Public Function Recursion(ByVal whereItEnds As Long, lookingFor As Variant, _
ByRef currentMarker As Range, ByVal i As Long, _
ByRef wsEverything As Worksheet) As Long
Dim col As Long, newMarker As String, currentMarker1 As Range
newMarker = currentMarker.Value
Recursion = 2
col = 2
If StrComp(lookingFor, newMarker, vbTextCompare) = 0 Then Exit Function
While Len(wsEverything.Cells(col, "B").Value2) > 0
If StrComp(wsEverything.Cells(col, "B").Value2, newMarker, vbTextCompare) = 0 Then
wsEverything.Cells.Range("A" & col, "F" & col).Copy
Worksheets("Review").Cells.Range("A" & i).PasteSpecial
Worksheets("Review").Cells.Range("G" & i).Value = col
i = i + 1
Set currentMarker1 = wsEverything.Cells(col, "E")
If col = whereItEnds Then Exit Function
Recursion = Recursion(whereItEnds, lookingFor, currentMarker1, i, wsEverything)
End If
col = col + 1
Wend
End Function
If so, you can provide more context explaining the logic for the expected result
Probably a less convoluted solution can be found for this
I need to do it for more than 1000 cells, to read the particular data and to put under respective cells using Excel VBA.
Example:
Name Age No. .. .
abc 14 123454 ------>this from single cell
Which contains like Name: abc,Age: 14, No: 123454
This should be a good start :
Sub Split_N_Copy()
Dim InFo()
Dim InfSplit() As String
InFo = ActiveSheet.Cells.UsedRange.Value2
Sheets.Add after:=Sheets(Sheets.Count)
For i = LBound(InFo, 1) To UBound(InFo, 1)
'Here I put InFo(i,1), "1" if we take the first column
InfSplit = Split(InFo(i,1), ",")
For k = LBound(InfSplit) To UBound(InfSplit)
Sheets(Sheets.Count).Cells(i + 1, k + 1) = InfSplit(k)
Next k
Next i
End Sub
I write a function based on , for separator sign and : for equal sign, that search a range of data that first row contains headers:
Function UpdateSheet(allData As String, inRange As Range)
Dim strData() As String
Dim i As Long, lastRow As Long
Dim columnName As String, value As String
Dim cell As Range
'You need to change this to finding last row like this answer:
'http://stackoverflow.com/a/15375099/4519059
lastRow = 2
strData = Split(allData, ",")
For i = LBound(strData) To UBound(strData)
columnName = Trim(Left(strData(i), InStr(1, strData(i), ":") - 1))
value = Trim(Mid(strData(i), InStr(1, strData(i), ":") + 1))
For Each cell In inRange
If cell.Cells(1, 1).Rows(1).Row = 1 Then
If cell.Cells(1, 1).value Like "*" & columnName & "*" Then
inRange.Worksheet.Cells(lastRow, cell.Columns(1).Column).value = value
End If
End If
Next
Next
End Function
Now you can use that function like this:
Sub update()
Call UpdateSheet("Name: abc,Age: 14, No: 123454", Sheets(1).UsedRange)
End Sub
Private Sub CommandButton1_Click()
lastRow = Sheet1.Cells(Sheet1.Rows.Count, "G").End(xlUp).Row
Dim i As Integer
i = 2
For i = 2 To lastRow
Dim GetData As String
GetData = Sheet1.Cells(i, 7)
Call UpdateSheet(GetData, Sheets(1).UsedRange, i)
Next
End Sub
Function UpdateSheet(allData As String, inRange As Range, rowno As Integer)
Dim strData() As String
Dim i As Long, lastRow As Long
Dim columnName As String, value As String
Dim cell As Range
strData = Split(allData, ",")
For i = LBound(strData) To UBound(strData)
Value1 = Trim(Mid(strData(i), InStr(1, strData(i), ":") + 1))
If Value1 <> "" Then
columnName = Trim(Left(strData(i), InStr(1, strData(i), ":") - 1))
value = Trim(Mid(strData(i), InStr(1, strData(i), ":") + 1))
For Each cell In inRange
If cell.Cells(1, 1).Rows(1).Row = 1 Then
If cell.Cells(1, 1).value Like "*" & columnName & "*" Then
inRange.Worksheet.Cells(rowno, cell.Columns(1).Column).value = value
End If
End If
Next
End If
Next
End Function
I have a string compressed into one cell. I need to separate each part of the string into their own cell, while copying the data from the same row.
Here is my example data:
A | B
Row1 ABC ABD ABE ABF | CODE1
Row2 BCA DBA EBA FBA | CODE2
Row3 TEA BEF | CODE3
The result would be:
A B
ABC CODE1
ABD CODE1
ABE CODE1
ABF CODE1
BCA CODE2
DBA CODE2
EBA CODE2
FBA CODE2
TEA CODE3
BEF CODE3
I have about 2000 rows and would literally take 30 years to use the text to column function for this. So I am trying to write a vba macro. I think I am making this harder than it needs to be. Any thoughts or pushes in the right direction would be appreciated. Thanks in advance for any help.
This will work, (but it's mighty inefficient unless you do it in an array... nevertheless for only 2000 rows, you won't even notice the lag)
Function SplitThis(Str as String, Delimiter as String, SerialNumber as Long) As String
SplitThis = Split(Str, Delimiter)(SerialNumber - 1)
End Function
Use it as
= SPLITTHIS("ABC EFG HIJ", " ", 2)
' The result will be ...
"EFG"
You will still need to put in a whole lot of extra error checking, etc. if you need to use it for a distributed application, as the users might put in values greater than the number of 'split elements' or get delimiters wrong, etc.
I like iterating over cells for problems like this post.
' code resides on input sheet
Sub ParseData()
Dim wksOut As Worksheet
Dim iRowOut As Integer
Dim iRow As Integer
Dim asData() As String
Dim i As Integer
Dim s As String
Set wksOut = Worksheets("Sheet2")
iRowOut = 1
For iRow = 1 To UsedRange.Rows.Count
asData = Split(Trim(Cells(iRow, 1)), " ")
For i = 0 To UBound(asData)
s = Trim(asData(i))
If Len(s) > 0 Then
wksOut.Cells(iRowOut, 1) = Cells(iRow, 2)
wksOut.Cells(iRowOut, 2) = s
iRowOut = iRowOut + 1
End If
Next i
Next iRow
MsgBox "done"
End Sub
Assuming your data is on the first sheet, this populates the second sheet with the formatted data. I also assume that the data is uniform, meaning there is the same type of data on every row until the data ends. I did not attempt the header line.
Public Sub FixIt()
Dim fromSheet, toSheet As Excel.Worksheet
Dim fromRow, toRow, k As Integer
Dim code As String
Set fromSheet = Me.Worksheets(1)
Set toSheet = Me.Worksheets(2)
' Ignore first row
fromRow = 2
toRow = 1
Dim outsideArr() As String
Dim insideArr() As String
Do While Trim(fromSheet.Cells(fromRow, 1)) <> ""
' Split on the pipe
outsideArr = Split(fromSheet.Cells(fromRow, 1), "|")
' Split left of pipe, trimmed, on space
insideArr = Split(Trim(outsideArr(0)), " ")
' Save the code
code = Trim(outsideArr(UBound(outsideArr)))
' Skip first element of inside array
For k = 1 To UBound(insideArr)
toSheet.Cells(toRow, 1).Value = insideArr(k)
toSheet.Cells(toRow, 2).Value = code
toRow = toRow + 1
Next k
fromRow = fromRow + 1
Loop
End Sub
Let me try as well using Dictionary :)
Sub Test()
Dim r As Range, c As Range
Dim ws As Worksheet
Dim k, lrow As Long, i As Long
Set ws = Sheet1 '~~> change to suit, everything else as is
Set r = ws.Range("B1", ws.Range("B" & ws.Rows.Count).End(xlUp))
With CreateObject("Scripting.Dictionary")
For Each c In r
If Not .Exists(c.Value) Then
.Add c.Value, Split(Trim(c.Offset(0, -1).Value))
End If
Next
ws.Range("A:B").ClearContents
For Each k In .Keys
lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If lrow = 1 Then i = 0 Else i = 1
ws.Range("A" & lrow).Offset(i, 0) _
.Resize(UBound(.Item(k)) + 1).Value = Application.Transpose(.Item(k))
ws.Range("A" & lrow).Offset(i, 1).Resize(UBound(.Item(k)) + 1).Value = k
Next
End With
End Sub
Above code loads all items in Dictionary and then return it in the same Range. HTH.
Here is an approach using a User Defined Type, Collection and arrays. I've been using this lately and thought it might apply. It does make writing the code easier, once you get used to it.
The user defined type is set in a class module. I called the type "CodeData" and gave it two properties -- Code and Data
I assumed your data was in columns A & B starting with row 1; and I put the results on the same worksheet but in columns D & E. This can be easily changed, and put on a different worksheet if that's preferable.
First, enter the following code into a Class Module which you have renamed "CodeData"
Option Explicit
Private pData As String
Private pCode As String
Property Get Data() As String
Data = pData
End Property
Property Let Data(Value As String)
pData = Value
End Property
Property Get Code() As String
Code = pCode
End Property
Property Let Code(Value As String)
pCode = Value
End Property
Then put the following code into a Regular module:
Option Explicit
Sub ParseCodesAndData()
Dim cCodeData As CodeData
Dim colCodeData As Collection
Dim vSrc As Variant, vRes() As Variant
Dim V As Variant
Dim rRes As Range
Dim I As Long, J As Long
'Results start here. But could be on another sheet
Set rRes = Range("D1:E1")
'Get Source Data
vSrc = Range("A1", Cells(Rows.Count, "B").End(xlUp))
'Collect the data
Set colCodeData = New Collection
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), " ")
For J = 0 To UBound(V)
Set cCodeData = New CodeData
cCodeData.Code = Trim(vSrc(I, 2))
cCodeData.Data = Trim(V(J))
colCodeData.Add cCodeData
Next J
Next I
'Write results to array
ReDim vRes(1 To colCodeData.Count, 1 To 2)
For I = 1 To UBound(vRes)
Set cCodeData = colCodeData(I)
vRes(I, 1) = cCodeData.Data
vRes(I, 2) = cCodeData.Code
Next I
'Write array to worksheet
Application.ScreenUpdating = False
rRes.EntireColumn.Clear
rRes.Resize(rowsize:=UBound(vRes, 1)) = vRes
Application.ScreenUpdating = True
End Sub
Here is the solution I devised with help from above. Thanks for the responses!
Sub Splt()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
Columns("A").Insert
For i = LR To 1 Step -1
With Range("B" & i)
If InStr(.Value, " ") = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, " ")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("B").Delete
LR = Range("A" & Rows.Count).End(xlUp).Row
With Range("B1:C" & LR)
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
This question already has answers here:
Find last used cell in Excel VBA
(14 answers)
Closed 2 years ago.
I need to copy paste big sheets, this is taking a lots of time.
I have been advised not to use .copy process on worksheets but rather proceeds cell by cell. Giving new cells each properties of the ancient cell. This is what I do here: Saving only some sheets in another Workbook.
To do it cells by cells I need to know the last cell containing information. (not only value, but colour, borders... etc). I've seen many simple solution on internet, but they all have a problem.
ActiveSheet.UsedRange.Rows.Count often gives too many values... I got a 810 * 16000 answer for a 5 * 18 table
range("A" & activesheet.rows.count).end(xlup).row works only for the first columns...
What would be the best way to procedd to final the real last line with value ? containig information (value, colour, border...)
This command in Excel 2010 ActiveCell.SpecialCells(xlLastCell).Select will move the cursor (active cell) to the last one that had a non-trivial value, even if the cell currently is blank
This command Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select will select all cells from the current to the last one that had a non-trivial value.
Both these approaches work for me for getting the last cell 2007. I have used the "UsedRange" method in Excel 2003 as well.
If they do not work for you then your spreadsheet may have something in it that Excel is not showing you. This has happened to me before. The fix would be to select every empty row below your real data and right-Click->Delete them (Same with columns to the right).
Shortcut to delete rows: Shift+Space, Shift+Control+DownArrow, Rightclick->Delete
Shortcut to delete columns: Control+Space, Shift+Control+RightArrow, Rightclick->Delete
examples:
set lastCell = ActiveCell.SpecialCells(xlLastCell)
or
Set lastCell = worksheetObj.UsedRange.Item(worksheetObj.UsedRange.Cells.Count)
Save the Following code to a class file name FinalRowLocator
Public Property Get FinalRow(Optional ByVal Col As String, Optional ByVal Min As Boolean) As Long
FinalRow = pFinalRow(Col, Min)
End Property
Public Property Get Verify(Optional ByVal Col As String, Optional ByVal Min As Boolean) As Long
Verify = pVerify(Col, Min)
End Property
Private Function pVerify(Optional ByVal Col As String, Optional ByVal Min As Boolean) As Long
Dim i As Long
Dim j As Long
Dim rVerify As Long
Dim Votes(1 To 5) As Byte
Dim Congress(1 To 5) As Long
Dim FRL As New FinalRowLocator
Congress(1) = FRL.Columbus
Congress(2) = FRL.GosEgg
Congress(3) = FRL.OldTimer
Congress(4) = FRL.RainMan
Congress(5) = FRL.Slacker
For i = 1 To 5
For j = 1 To 5
If Congress(i) = Congress(j) Then Votes(i) = Votes(i) + 1
Next j
Next i
For i = 1 To 5
If rVerify < Congress(i) Then rVerify = i
Next i
pVerify = Congress(rVerify)
End Function
Public Property Get GosEgg(Optional ByVal Col As String) As Long
GosEgg = pFinalRow_M1(Col)
End Property
Public Property Get RainMan(Optional ByVal Col As String) As Long
RainMan = pFinalRow_M2(Col)
End Property
'Public Property Get MathIt() As Long
' MathIt = pFinalRow_M3
'End Property
Public Property Get OldTimer() As Long
OldTimer = pFinalRow_M4
End Property
Public Property Get Columbus() As Long
Columbus = pFinalRow_M5
End Property
Public Property Get Slacker(Optional ByVal Col As Long) As Long
Slacker = pFinalRow_M6(Col)
End Property
Private Function pFinalRow(Optional ByVal Col As String, Optional ByVal Min As Boolean) As Long
Dim FinalRow As Long
Select Case Col
Case Is = ""
Select Case Min
Case False
If pFinalRow_M1 > pFinalRow_M2 Then FinalRow = pFinalRow_M1
If pFinalRow_M1 < pFinalRow_M2 Then FinalRow = pFinalRow_M2
'If pFinalRow_M3 > FinalRow Then FinalRow = pFinalRow_M3
If pFinalRow_M5 > FinalRow Then FinalRow = pFinalRow_M5
If pFinalRow_M6 > FinalRow Then FinalRow = pFinalRow_M6
Case True
If pFinalRow_M1 < pFinalRow_M2 Then FinalRow = pFinalRow_M1
If pFinalRow_M1 > pFinalRow_M2 Then FinalRow = pFinalRow_M2
'If pFinalRow_M3 < FinalRow Then FinalRow = pFinalRow_M3
If pFinalRow_M5 < FinalRow Then FinalRow = pFinalRow_M5
If pFinalRow_M6 < FinalRow Then FinalRow = pFinalRow_M6
End Select
Case Is <> 0
Select Case Min
Case False
If pFinalRow_M1(Col) > FinalRow Then FinalRow = pFinalRow_M1(Col)
If pFinalRow_M2(Col) > FinalRow Then FinalRow = pFinalRow_M2(Col)
Case True
If pFinalRow_M1(Col) < FinalRow Then FinalRow = pFinalRow_M1(Col)
If pFinalRow_M2(Col) < FinalRow Then FinalRow = pFinalRow_M2(Col)
End Select
End Select
'If pFinalRow_M4 > FinalRow Then FinalRow = pFinalRow_M4 'Disabled, lags behind.
pFinalRow = FinalRow
End Function
Private Function pFinalRow_M1(Optional ByRef ColLtr As String) As Long
If ColLtr = "" Then ColLtr = "A"
pFinalRow_M1 = Range(ColLtr & "65536").End(xlUp).Row
End Function
Private Function pFinalRow_M2(Optional ByRef Col As String) As Long
Dim i As Byte
Dim FinalRow As Long
Select Case Col
Case Is = ""
For i = 1 To 26
If FinalRow < Cells(ActiveSheet.Rows.Count, i).End(xlUp).Row Then FinalRow = Cells(ActiveSheet.Rows.Count, i).End(xlUp).Row
Next i
Case Is <> ""
FinalRow = Cells(ActiveSheet.Rows.Count, Col).End(xlUp).Row
End Select
pFinalRow_M2 = FinalRow
End Function
Private Function pFinalRow_M3() As Long
Dim FinalRow As Long
Dim ASUC As Long
ASUC = ActiveSheet.UsedRange.Count
FinalRow = ASUC / pFinalRow_M2
pFinalRow_M3 = FinalRow
End Function
Private Function pFinalRow_M4() As Long
'Works on unmodified (saved) sheet only.
Selection.SpecialCells(xlCellTypeLastCell).Select
pFinalRow_M4 = ActiveCell.Row
End Function
Private Function pFinalRow_M5() As Long
On Error GoTo ErrorHandler
'May have problems with hidden rows
'This Method returns 0 on a sheet with no data while the others return 1
pFinalRow_M5 = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
Exit Function
ErrorHandler:
Select Case Err.Number
Case 91
'Assume Error is due to no data, return 0
pFinalRow_M5 = 0
Resume Next
Case Else
On Error GoTo 0
End Select
End Function
Private Function pFinalRow_M6(Optional ByRef ColLtr As Long) As Long
If ColLtr <= 0 Then ColLtr = 1
pFinalRow_M6 = Sheets(ActiveSheet.Name).Cells(Rows.Count, ColLtr).End(xlUp).Row
End Function
Public Function Diagnostics_Run()
Dim FRL As New FinalRowLocator
MsgBox "Columbus: " & FRL.Columbus & Chr(13) _
& "FinalRow: " & FRL.FinalRow & Chr(13) _
& "GosEgg: " & FRL.GosEgg & Chr(13) _
& "OldTimer: " & FRL.OldTimer & Chr(13) _
& "RainMan: " & FRL.RainMan & Chr(13) _
& "Slacker: " & FRL.Slacker '& _
' _ & "MathIt: " & FRL.MathIt & Chr(13)
End Function
Public Property Get DoubleCheck(ByVal Result1 As Long, ByVal Result2 As Long) As Boolean
If Result1 <> Result2 Then DoubleCheck = False
If Result1 = Result2 Then DoubleCheck = True
End Property
Private Property Get pPara()
Dim FRL As New FinalRowLocator
pPara = FRL.FinalRow(, Not FRL.DoubleCheck(FRL.FinalRow, FRL.Verify))
End Property
Public Property Get Para()
Para = pPara
End Property
then:
Dim FLR as new FinalRowLocator
Dim FinalRow as Long
FinalRow = FRL.FinalRow
Provided you have ascertained the correct finalrow, the following should work.
'This will return the column letter
'This Function is dependant on FinalRow returning the correct value.
Dim rInt As Long
rInt = ActiveSheet.UsedRange.Count
psFinalCol = Chr((rInt / FinalRow) + 64)
'This will return the column number
'This Function is dependant on FinalRow returning the correct value.
Dim rInt As Long
rInt = ActiveSheet.UsedRange.Count
piFinalCol = rInt / FinalRow
Additional Usage Information:
Dim FRL as New FinalRowLocator 'Create an instance of the FinalRowLocator Class
Dim FinalRow as Long 'Declare the FinalRow Variable as Long
FinalRow = FRL.FinalRow 'Gets the Highest Number returned from all methods
FinalRow = FRL.FinalRow("", true) 'Returns the lowest number from all methods
FinalRow = FLR.FinalRow("A") 'Gets the highest number (column A) returned from methods 1 & 2
FinalRow = FRL.FinalRow("A", true) 'Gets the lowest number (column A) returned from methods 1 & 2
'FRL.DoubleCheck(FRL.FinalRow, FRL.Verify) 'returns true or false based on if the values match
FinalRow.Para is the same as FRL.FinalRow(, Not FRL.DoubleCheck(FRL.FinalRow, FRL.Verify)) 'Returns the lowest row number if the highest one can not be verified.
'FRL.Verify Determins the FinalRow in a Democratic Manner.
FRL.Diagnostics 'will display the results of each individual method in a msgbox
'***** Methods
FRL.Columbus 'Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row 'May have problems with hidden rows 'This Method returns 0 on a sheet with no data while the others return 1
FRL.GosEgg 'does not count past 65536 rows [Range(ColLtr & "65536").End(xlUp).Row]
FRL.OldTimer 'Selection.SpecialCells(xlCellTypeLastCell).Select [Works on Unmodified Saved Sheet Only]
FRL.RainMain 'Cells(ActiveSheet.Rows.Count, Col).End(xlUp).Row
FRL.Slacker 'Sheets(ActiveSheet.Name).Cells(Rows.Count, ColLtr).End(xlUp).Row