Excel VBA 几个实用工具函数---统计行列、新建文件、复制黏贴、查表

Excel VBA 几个实用工具函数

1. 获取列数（允许中间有空列）

Function getCols(sheetname As String, row As Integer, skips As Integer)
Dim emptyboxs As Integer, usedcolums As Integer
	emptyboxs = 0
For usedcolums = 1 To Worksheets(sheetname).UsedRange.Columns.Count
    If (emptyboxs <= skips And (Not (Worksheets(sheetname).Cells(row, usedcolums).Value = ""))) Then
        emptyboxs = 0
    End If
    If (Worksheets(sheetname).Cells(row, usedcolums).Value = "") Then
        emptyboxs = emptyboxs + 1
    End If
    If (emptyboxs > skips) Then
        Exit For
    End If
Next usedcolums
usedcolums = usedcolums - (skips + 1)
getCols = usedcolums
End Function

传入参数：sheetname 工作表名，row 参考行所在行号，skips 允许跳过的空白列
返回值：列数

样例

dim cols as Integer
cols=getCols("样表",2,2)

2. 创建新工作簿（覆盖/打开旧工作簿）

Function make_new_excel(name As String, Optional cover As Boolean = True)
Dim root As String
root = ThisWorkbook.path
Dim path As String
'可以自行改动生成路径，默认是本文档所在目录
path = root  & name & ".xlsx"  
ex = Len(Dir(path, vbDirectory))
Application.ScreenUpdating = False
If cover Then
    If ex <> 0 Then
        On Error GoTo fileopen
        Kill path
    End If
Else
    If ex <> 0 Then
        Set make_new_excel = Application.Workbooks.Open(path)
        Exit Function
    End If
End If
fileopen:
    If Err.Number = 70 Then
        Workbooks(name & ".xlsx").Close
        Kill path
    End If
    Workbooks.add
    ActiveWorkbook.SaveAs fileName:=path, _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Set make_new_excel = Application.Workbooks.Open(path)
    Application.ScreenUpdating = True

End Function

传入参数：name 新建的工作簿名，cover [可选，默认覆盖] 是否覆盖旧文件
返回值：工作簿句柄

样例

dim testWorkbook as WorkBook
set testWorkbook=make_new_excel("样表",false)

3.快速粘贴（支持选择性粘贴）

Sub easy_paste(sheetid As Integer, file As Workbook, paste_postion As String, Optional mode As Integer = 0)
    'mode=0 仅数值和数字格式
    'mode=1 全部格式
    
    Application.ScreenUpdating = False
    file.Worksheets(sheetid).Activate
    Range(paste_postion).Select
    
        Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=True, Transpose:=False
            
        If mode = 1 Then
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        End If
        
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=False
            
    Range("A1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

传入参数：sheetid 工作表号，file 工作簿句柄，paste_position 粘贴的起 始位置，mode 粘贴模式

样例

dim targetWorkbook as WorkBook
'定义targetWorkbook
'initialize:
sheets("源表").Activate
Range("A1:F30").Copy
'先复制一个区域
Call easy_paste(1, targetWorkbook, "B" & 5)
'在目标表中从B5单元格开始粘贴

4.在表中查找关键字（所有满足条件的单元格）

Function seekTarget(target As String，LimitRange as String)

Dim rng As Range
Dim c As New Collection

Set rng = Range(LimitRange).find(target)
If Not rng Is Nothing Then
        firstAddress = rng.Address
        Do
            c.add rng.row'这里仅记录符合条件的单元格的行号，可自行更改
            Set rng = Range(LimitRange).FindNext(rng)
        Loop While Not rng Is Nothing And rng.Address <> firstAddress
    End If
    Set seekTarget = c
End Function

传入参数：target 查询关键字，LimitRange 限定查询区域
返回值：满足条件的单元格行号的集合（可自行修改）

样例

dim test_match as New Collection
set test_match=seekTarget("关键字","A3:Z500")