万能取有数据最后行号自定义函数(VBA专用)

小花鹿

自己平时给别人写代码时，经常要取某列（如：A）或某个列范围（如：A:Z）最后有数据的行号，以便于进行后续的代码编写，但是，有时要考虑隐藏行或筛选等情况，所以，写一个自定义函数，能够在任何情况下，不对工作表作任何变动而能正确的得到行号。
会存在错误或效率问题，请有兴趣的帮忙优化。
Sub test1()
MsgBox endrow("a:b","sheet1")
End Sub
Function endrow(Optional myc As String, Optional mysht As String)
    '得到有数据的最后行号，两个参数均可选
    '参数形式如：myc是列范围，如"A:B",如果忽略则为整个工作表
    '            mysht是指工作表，如"sheet1"，如果忽略则为活动工作表
    Dim sht, ar, r&, i&, j&, s
    If mysht = "" Then
        Set sht = ActiveSheet
    Else
        Set sht = Sheets(mysht)
    End If
    ar = sht.UsedRange
    r = sht.UsedRange.Range("a1").Row
    If IsArray(ar) Then
        For i = UBound(ar) To 1 Step -1
            For j = 1 To UBound(ar, 2)
                If ar(i, j) <> "" Then
                    r = i + r - 1
                    s = ar(i, j)
                    GoTo label1
                End If
            Next j
        Next i
label1:
    Else
        s = ar
    End If
    If s = "" Then r = 0
    If myc = "" Or r = 0 Then
        endrow = r
        Exit Function
    End If
    s = ""
    Dim c
    c = Split(myc, ":")
    ar = sht.Range(c(0) & "1:" & c(1) & r)
    If IsArray(ar) Then
        For i = UBound(ar) To 1 Step -1
            For j = 1 To UBound(ar, 2)
                If ar(i, j) <> "" Then
                    r = i
                    s = ar(i, j)
                    GoTo label2
                End If
            Next j
        Next i
label2:
    Else
        s = ar
    End If
    If s = "" Then r = 0
    endrow = r
End Function

====================================================================
学习9楼老师的代码，修改成自定义函数，方便使用：
Sub test2()
MsgBox EndRow("a:b", "sheet2")
End Sub
Function EndRow(Optional myc As String, Optional mysht As String)
    '得到有数据的最后行号，两个参数均可选
    '参数形式如：myc是列范围，如"A:B",如果忽略则为整个工作表
    '            mysht是指工作表，如"sheet1"，如果忽略则为活动工作表
    Dim rng As Range, sht As Worksheet, ar, i&, j&
    If mysht <> "" Then
        Set sht = Sheets(mysht)
    Else
        Set sht = ActiveSheet
    End If
    If myc = "" Then
        Set rng = sht.UsedRange
    Else
        Set rng = Intersect(sht.UsedRange, sht.Range(myc))
    End If
    If rng Is Nothing Then
        EndRow = 0
        Exit Function
    End If
    ar = rng.Value
    If Not IsArray(ar) Then
        If Len(ar) = 0 Then
            EndRow = 0
            Exit Function
        Else
            EndRow = rng.Row
            Exit Function
        End If
    Else
        For i = UBound(ar) To 1 Step -1
            For j = 1 To UBound(ar, 2)
                If Len(ar(i, j)) Then
                    EndRow = i - 1 + rng.Row
                    Exit Function
                End If
            Next j
        Next i
    End If
    EndRow = 0
End Function
=============================================================
修改一下，可以求行号和列号，有兴趣的帮忙测试一下：
Sub test2()
Dim s1$, s2$, s
s1 = [m1]
s2 = [m2]
s = EndRC(s1, s2)
MsgBox s(1) & "," & s(2)
End Sub
Function EndRC(Optional MyRange As String, Optional MySht As String)
    '函数返回结果为两个元素的一维数组，EndRC(1)代表最后行号，EndRC(2)代表最后列号
    '得到指定范围的有数据的最后行列号，两个参数均可选
    '参数形式如：MyRange是指定范围，形如，整列"A:B"、整行"6:26"、矩形区域"a6:h26",如果忽略则为UsedRange
    '            MySht是指工作表，如"sheet1"，如果忽略则为活动工作表
    Dim rng As Range, sht As Worksheet, ar, i&, j&, RC(1 To 2) As Long
    If MySht <> "" Then
        Set sht = Sheets(MySht)
    Else
        Set sht = ActiveSheet
    End If
    If MyRange = "" Then
        Set rng = sht.UsedRange
    Else
        Set rng = Intersect(sht.UsedRange, sht.Range(MyRange))
    End If
    If rng Is Nothing Then
        GoTo label1
    End If
    ar = rng.Value
    If Not IsArray(ar) Then
        If Len(ar) = 0 Then
            GoTo label1
        Else
            RC(1) = rng.Row
            RC(2) = rng.Column
            GoTo label1
        End If
    Else
        For i = UBound(ar, 2) To 1 Step -1
            For j = 1 To UBound(ar)
                If Len(ar(j, i)) Then
                    RC(2) = i - 1 + rng.Column
                    GoTo label2
                End If
            Next j
        Next i
label2:
        For i = UBound(ar) To 1 Step -1
            For j = 1 To UBound(ar, 2)
                If Len(ar(i, j)) Then
                    RC(1) = i - 1 + rng.Row
                    GoTo label1
                End If
            Next j
        Next i
    End If
label1:
    EndRC = RC
End Function

xj123321

学习了            

opiona

行都有了，再来个列的

blackttea1

学习了     

zopey

1. Sub test()
   
2. Dim rng As Range
   
3. Set rng = Worksheets("sheet1").Columns("a:c")
   
4. 
   
5. Dim rnga As Range
   
6. Set rnga = rng.Find(what:="*")
   
7. Set rnga = rng.FindPrevious(after:=rnga)
   
8. 
   
9. MsgBox rnga.Row
   
10. End Sub

复制代码

小花鹿

zopey 发表于 2019-1-30 16:45

筛选状态下不行，请修改一下

zopey

小花鹿 发表于 2019-1-31 13:28
筛选状态下不行，请修改一下

隐藏单元格内容 ，find 不适用。

小花鹿

zopey 发表于 2019-1-31 14:32
隐藏单元格内容 ，find 不适用。

我的意思是要在任何情况下都能正确得到有数据的最后行号，而且不对单元格做任何操作，你有没有更简单的方法

zopey

小花鹿 发表于 2019-1-31 19:55
我的意思是要在任何情况下都能正确得到有数据的最后行号，而且不对单元格做任何操作，你有没有更简单的方 ...

1. Sub test()
   
2. Dim rng As Range
   
3. With Worksheets("sheet1")
   
4.     Set rng = Intersect(.UsedRange, .Columns("a:d"))
   
5. End With
   
6. 
   
7. Dim arr
   
8. arr = rng
   
9. 
   
10. For i = UBound(arr) To 1 Step -1
    
11. For j = 1 To UBound(arr, 2)
    
12.    If Len(arr(i, j)) > 0 Then MsgBox i - 1 + rng.Row: Exit Sub
    
13. Next
    
14. Next
    
15. 
    
16. End Sub

复制代码

赋值给数组，应该可以

YZC51

谢谢分享！！！