我的VBA自定义函数研习收获

weiyingde

用VBs批量创建文件夹。
用法：创建一个text文件，将代码写进去，然后再将后缀".txt"改为“.vbs”,双击即可生成。
sr = "浙江,江苏,广东,福建,山东,四川,甘肃,贵州,江西,山西,河北,安徽,河南,黑龙江,吉林,辽宁,青海,陕西,湖南,海南,云南,广西,内蒙古,新疆,宁夏"
arr = split(sr,",")
rem array("北京,天津,重庆,浙江,江苏,广东,福建,山东,四川,甘肃,贵州,江西,河北,安徽,河南,黑龙江,吉林,辽宁,青海,陕西,湖南,海南,云南,广西,内蒙古,新疆,宁夏")
for i =0 to Ubound(arr)
CreateFolders "D:\上传\真题集萃\真题系列\中考\中考真题\其他\2023年\" & arr(i)   
next
Function CreateFolders(path)     
Set fso = CreateObject("scripting.filesystemobject")
CreateFolderEx fso,path   
set fso = Nothing
End Function  

Function CreateFolderEx(fso,path)
  If fso.FolderExists(path) Then         
    Exit Function   
  End If   
If Not fso.FolderExists(fso.GetParentFolderName(path)) Then        
   CreateFolderEx fso,fso.GetParentFolderName(path)
End If   
fso.CreateFolder(path)
End Function

weiyingde

朗读文本过程
注意，电脑中必须安装对应的语音
在我的机器上，Nb为0,4,5均可读，4,5效果较好。
Sub spek(str As String.Nb)
Set sapk = CreateObject("SAPI.SpVoice")
With sapk
   .volume = 100 '音量
   .Rate = -10 '语音速率 越大越快 -10至+10
    FlagsAsync = 1 '同步或异步，0是同步 1是异步
    Set .Voice = .GetVoices.Item(Nb)
   .Speak str, False
End With
Set sapk = Nothing
End Sub

weiyingde

汉字笔画数函数，适用于小学低年级，方便于语文教师语文教学和资料整理。根据本坛资料进行整理和勘误。集合繁体和简体汉字20901个汉字，并对守柔提供的汉字库，和不知名提供的字库笔画数进行订正。本版本为相对全面和正确的版本。

weiyingde

偏旁函数，可适用于查找7011个汉字的偏旁查找。提供bas下载。

weiyingde

求利用网络资源，抓取汉字笔顺的过程或函数。
请大虾或过路人添加。

weiyingde

根据拼音取首字母，大写输出。

张劲松2024

学习了，谢谢提供，辛苦！！！！！！！！！！！

weiyingde

阿拉伯数字与中文大小写互转函数。支持16位（千兆）大数的转换，绝对好用，实现一箭三雕的效果。
'函数功能：阿拉伯数字与中文大小写互转：
'参数kg不同的值对应功能如下：
'kg值     功能         示例输入            示例输出
' 0     阿拉伯数字 →  中文小写        1024        "一千〇二十四"
' 1     阿拉伯数字 →  中文大写        1024        "壹仟零贰拾肆"
' 2       中文     →  阿拉伯数字       "一千〇二十四"  1024

weiyingde

数组转置并排序输出。
Function TspArr(arr As Variant, Optional Kg As Integer = 0, Optional Nb As Integer = 0) As Variant
'作用：替代Excel中worksheetfunction的transpose函数。
'特点：支持一维数组和二维数组。参数kg和Nb说明：
'参数Kg 没有——不排序；参数Kg = 0，转换后排序输出（Nb为0降序，Nb为1升序）。
'参数Kg =N（>=1），转换后按照N列排序输出（Nb为0降序，Nb为1升序）
'调用示例：
'Sub 转置输出()
'With ActiveSheet
'   brr = Sheets("重组").Range("A1:M46")
'   arr = TspArr(brr, 3, 0)   '不可直接写成arr = TspArr(Sheets("重组").Range("A1:M46"), 3, 0)，因为单元格区域不是数组
'   [a1].Resize(UBound(arr), UBound(arr, 2)) = arr
'End With
'End Sub
   
    Dim tArr() As Variant ' 转置后的数组
    Dim m As Long, n As Long ' 原数组行数、列数
    Dim i As Long, j As Long, l As Long ' 循环变量
    Dim is1D As Boolean ' 标记是否为一维数组
    Dim sortCol As Long ' 排序依据的列
    Dim temp() As Variant ' 排序交换用临时数组
    Dim cols As Long, rows As Long ' 转置后数组的列数、行数
    Dim val1 As Variant, val2 As Variant ' 用于安全比较的临时值
   
    ' 检查输入是否为数组，非数组返回错误
    If Not IsArray(arr) Then
        TspArr = CVErr(xlErrValue)
        Exit Function
    End If
   
    ' --------------------------
    ' 第一步：处理数组转置
    ' --------------------------
    On Error Resume Next ' 用于判断数组维度
    n = UBound(arr, 2) ' 尝试获取第二维度（二维数组的列数）
    is1D = (Err.Number <> 0) ' 若报错，说明是一维数组
    On Error GoTo 0
   
    If is1D Then
        ' 一维数组转置（转为1列的二维数组）
        m = UBound(arr) - LBound(arr) + 1 ' 原数组元素总数
        ReDim tArr(1 To m, 1 To 1) ' 转置后：m行1列（索引从1开始）
        For i = 1 To m
            tArr(i, 1) = arr(LBound(arr) + i - 1)
        Next i
    Else
        ' 二维数组转置（交换行和列）
        m = UBound(arr, 1) - LBound(arr, 1) + 1 ' 原数组行数
        n = UBound(arr, 2) - LBound(arr, 2) + 1 ' 原数组列数
        ReDim tArr(1 To n, 1 To m) ' 转置后：n行m列（原列数→行数，原行数→列数）
        For i = 1 To n ' 遍历原数组的列（转置后为行）
            For j = 1 To m ' 遍历原数组的行（转置后为列）
                tArr(i, j) = arr(LBound(arr, 1) + j - 1, LBound(arr, 2) + i - 1)
            Next j
        Next i
    End If
   
    ' 获取转置后数组的行数和列数
    rows = UBound(tArr, 1)
    cols = UBound(tArr, 2)
   
    ' --------------------------
    ' 第二步：安全排序（跳过表头+处理异常值）
    ' --------------------------
    If Kg = 0 Or Kg >= 1 Then
        sortCol = IIf(Kg = 0, 1, Kg)
        If sortCol > cols Then sortCol = cols
        
        ' 冒泡排序（仅对数据行，兼容错误值和文本数字）
        For i = 2 To rows - 1
            For l = i + 1 To rows
                ' 安全获取比较值（处理错误值和文本数字）
                val1 = tArr(i, sortCol)
                val2 = tArr(l, sortCol)
               
                ' 过滤错误值（错误值视为最小，排在最后）
                If IsError(val1) Then val1 = -1E+307
                If IsError(val2) Then val2 = -1E+307
               
                ' 文本数字转为数值（如"123"→123）
                If Not IsNumeric(val1) Then val1 = -1E+307
                If Not IsNumeric(val2) Then val2 = -1E+307
                val1 = CDbl(val1)
                val2 = CDbl(val2)
               
                ' 判断是否交换（Nb=0降序；Nb=1升序）
                If (Nb = 0 And val1 < val2) Or (Nb = 1 And val1 > val2) Then
                    ReDim temp(1 To cols)
                    For j = 1 To cols
                        temp(j) = tArr(i, j)
                        tArr(i, j) = tArr(l, j)
                        tArr(l, j) = temp(j)
                    Next j
                End If
            Next l
        Next i
    End If
   
    TspArr = tArr
End Function