vba 公共方法集锦

'公共方法：查找文件,并打开文件，返回文件对象
'参数：path,文件所在路径
'文件名：模糊查询时的文件名
Public Function findAndOpenFiles(path As String, fileName1 As String) As Workbook
        Dim openWB As Workbook


        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fld = fso.Getfolder(path)
        Set fsb = fld.subfolders
        
        
        
        For Each fd In fsb                  'ergodic folders
            fileName = Dir(fd & "\" & fileName1 & "*.xlsx")
            Do While fileName <> ""         'ergodic files
                Set openWB = Workbooks.Open(fd & "\" & fileName)
                Set findAndOpenFiles = openWB
                Exit For
            Loop
        Next fd
End Function
'公共方法：查找文件,返回文件名称
'参数：path,文件所在路径
'文件名：模糊查询时的文件名
Public Function findFiles(path As String, fileName1 As String) As String()
        Dim Arr() As String
        
        
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fld = fso.Getfolder(path)
       ' Set fsb = fld.subfolders
        
        
        i = 0
        ReDim Arr(0)
        Arr(0) = ""
        For Each fd In fld.Files                'ergodic files
            If InStr(fd, fileName1) > 0 Then
                ReDim Preserve Arr(i)
                Arr(i) = fd
                i = i + 1
            End If
        Next fd
        
        findFiles = Arr
End Function


'公共方法：在最后创建一个新的sheet页，sheet页名为sheetName
Public Sub addWorkSheetAfterLast(openWB As Workbook, sheetName As String)
    On Error Resume Next
    openWB.Worksheets.Add(After:=openWB.Worksheets(openWB.Worksheets.Count)).Name = sheetName
End Sub


'公共方法：根据筛选后结果创建新文件
Sub createWorkbook(bcmWB As Workbook, bcmSh As Worksheet, filterName As String, fileName As String) 'filterName:是


    Dim yesBcmWB As Workbook
    Dim lastRow As Long
    
    'path: 代表文件所在路径
    'fileName：用于存放路径下所有交通银行的文件名
    'bcmWB :该workbook对象用于存放原始交行表格
    'yesBcmWB：该workbook对象用于存放同行交行表格
    'noBcmWB：该workbook对象用于存放跨行交行表格
    'bcmSh: bcmWB的sheet1
    'lastRow:原始数据最后一行行号
        With bcmSh
             .Activate
            '获取最后一行数据行号
            lastRow = .Range("A1").End(xlDown).Row
            '判断是否有添加过滤器，有则不做操作，无则添加过滤
            If .Range("G1").AutoFilter = True Then
            Else
                .Range("G1").Select
                Selection.AutoFilter
            End If
            
            '筛选出“是”
             .Range("$A$1:$H$" & lastRow).AutoFilter Field:=7, Criteria1:=filterName
            '过滤后最后一行
            lastRow = .Range("A65533").End(xlUp).Row
            
        End With
        
        '如果筛选后最后一行等于第一行，则无需生成同行，跨行文件
        If lastRow = 1 Then
           
        Else
             '创建新文件
             Workbooks.Add
             If filterName = "是" Then
                ActiveWorkbook.SaveAs Replace(fileName, ".xls", "_同行.xls"), True
               
             Else
                ActiveWorkbook.SaveAs Replace(fileName, ".xls", "_跨行.xls"), True
               
             End If
             Set yesBcmWB = ActiveWorkbook
                  
             '复制粘贴进新sheet页
             bcmWB.Activate
             bcmSh.Activate
             bcmSh.Range("A1:H" & lastRow).Select
             Selection.Copy
             yesBcmWB.Sheets(1).Activate
             yesBcmWB.Sheets(1).Range("A1").Select
             ActiveSheet.Paste      
             yesBcmWB.Save
             yesBcmWB.Close
        End If
        

End Sub

'公共方法:查找字符所在行列
Public Function findRange(txt As String, rng As Range)
    Dim firstr, firstc
    Dim Arr()
    
    ReDim Arr(1)
    firstr = rng.Row
    firstc = rng.Column
    Set cell = rng.Find(what:=txt, LookIn:=xlValues)
    If Not cell Is Nothing Then
        Arr(0) = cell.Row - firstr + 1
        Arr(1) = cell.Column - firstc + 1
        
    Else
        Arr(0) = ""
        Arr(1) = ""
    End If
    
    findRange = Arr
End Function