查看: 40  |  回复: 0
  VBA代码 E8常用函数
楼主
发表于 2025年3月18日 10:04
Function E8_Parameters(name, rng)    '参数表
    '查找参数表返回对应值,代替常规设置名称,简化操作
    Set E8_Parameters = rng.Columns(1).Find(what:=name, LookAt:=xlWhole).Offset(0, 1)
End Function

Function E8_UsedRange(sht As Worksheet)    '通过最大行来确定使用区域 系统使用区域有时候不准
    Dim endrow, endCol
    On Error Resume Next
    Set E8_UsedRange = Nothing
    endrow = sht.Cells.Find("*", sht.Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row    '计算最后一个非空行号
    endCol = sht.Cells.Find("*", sht.Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column    '计算最后一个非空列号
    Set E8_UsedRange = sht.Range(sht.[A1], sht.Cells(endrow, endCol))
End Function

Function E8_MaxRange(rng As Range, Optional col = "") As Range    '某一起始行区域往下延展的最大 默认按所有列最大行 也可指定参考列
    Dim endrow    'E8_MaxRange([A1:D1],"D").Select
    If col = "" Then col = rng.EntireColumn.Address
    endrow = rng.Columns(col).EntireColumn.Cells.Find("*", rng.Columns(col)(1), xlValues, xlWhole, xlByRows, xlPrevious).Row    '计算工作表的最后一个非空行号
    Set E8_MaxRange = rng.Resize(endrow - rng(1).Row + 1)
End Function

Public Function E8_LastRow(rng As Range)    '返回rng所在列的最后行数
    Dim rmax&
    rmax = ActiveSheet.Rows.Count
    E8_LastRow = rng.Worksheet.Cells(rmax, rng.Column).End(xlUp).Row
End Function

Function E8_InStrlist(s, slist)    '在一串字符串中检测是否存在
    Dim e
    InStrlist = False
    For Each e In slist
        If InStr(UCase(s), UCase(e)) > 0 Then
            E8_InStrlist = True
            Exit Function
        End If
    Next
End Function

Function E8_Rnd(min, max)    '随机返回指定区间的实数
    E8_Rnd = Int((max - min + 1) * Rnd + min)
End Function

Sub E8_Vlookup(r待查 As Range, r源 As Range, r输出 As Range, 结果列, Optional keyCol = 1)
    '代替Vlookup完成精确查找功能 直接输出源数据中查到的第一列结果果 避免表内公式重复计算
    'r输出只需要写起始第一行 结果列数要输出的数据在r源的列号数组如 [{2,3,4}]
    'E8_Vlookup [sheet2!A2:A416865], [sheet1!A1:B966026], [sheet2!B2], [{2}]
    Dim arr, brr, crr, i&, j&, k&, kdic&
    arr = r待查.Value
    brr = r源.Value
    Dim dic
    Set dic = CreateObject("scripting.dictionary")
    For i = 1 To UBound(brr)
        If Not dic.Exists(brr(i, keyCol)) And brr(i, keyCol) <> "" Then    '第一次遇到不存在key则加入字典 记录数据源行号
            dic.Add brr(i, keyCol), i
        End If
    Next
    '对比字典查找结果
    crr = r输出.Resize(UBound(arr)).Value
    For i = 1 To UBound(arr)
        If dic.Exists(arr(i, 1)) Then
            kdic = dic(arr(i, 1))
            For j = 1 To UBound(结果列)
                crr(i, j) = brr(kdic, 结果列(j))
            Next
        Else
            For j = 1 To UBound(结果列)
                crr(i, j) = ""
            Next
        End If
    Next
    r输出.Resize(UBound(arr)) = crr
End Sub

Sub RngCopyFormat(rng As Range, rngtarget As Range)    '复制格式
    rng.Copy
    rngtarget.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = xlCopy
End Sub


您需要登录后才可以回帖 登录 | 立即注册
【本版规则】请勿发表违反国家法律的内容,否则会被冻结账号和删贴。
用户名: 立即注册
密码:
2020-2025 MaNongKu.com