Colorful Life²⁰¹⁰

最近用VBA写了不少工作 上用的工具，一些常用或是容易出错的拿出来分享一下

1、检查一个XLS里是否存在指定SHEET页

Function SheetExists(ByVal wb As Workbook, ByVal SheetName As String) As Boolean
' returns TRUE if the sheet exists in the active workbook
    SheetExists = False
    On Error GoTo NoSuchSheet
    If Len(wb.Sheets(SheetName).Name) > 0 Then
        SheetExists = True
        Exit Function
    End If
NoSuchSheet:
    SheetExists = False
End Function

2、以弹出对话窗口(Dialog Window)的形式选择要打开的文件

Public Function GetOpenFile(ByVal app As Application, ByVal filters, ByVal stitle)
    If stitle = "" Then stitle = "Please select One File:"
    Dim vFile As Variant
    
    vFile = app.GetOpenFilename(filefilter:="All Supported Files," & filters, MultiSelect:=False, title:=stitle)
    If vFile <> False Then
        GetOpenFile = vFile
    Else
        GetOpenFile = ""
    End If
    Exit Function
End Function

示例：

    Set infile = Range("C5")
    infile.Value = GetOpenFile(Application, "*.csv;*.xls;*.xlsx", "")

3、以弹出对话窗口(Dialog Window)的形式选择要保存（另存为）的文件

Public Function GetSaveFile(ByVal app As Application, ByVal stitle, ByVal filename)
    If stitle = "" Then stitle = "Please select One File:"
    Dim vFile As Variant
    
    vFile = app.GetSaveAsFilename(InitialFileName:=filename, filefilter:="Office Workbooks(*.xls),*.xls", title:=stitle)
    If vFile <> False Then
        GetSaveFile = vFile
    Else
        GetSaveFile = ""
    End If
End Function

4、选择文件夹

Public Function GetFolder(ByVal title, ByVal defaultPath)
    Dim fd As Object
    Dim OutputFolder As String
    If title = "" Then title = "Please select One Folder:"
    'setup output folder
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        'open input file
        If defaultPath = "" Then
        .InitialFileName = Application.DefaultFilePath & "\"
        Else
            If Right(defaultPath, 1) = "\" Then
                .InitialFileName = defaultPath
            Else
                .InitialFileName = defaultPath & "\"
            End If
        End If
        .title = title
        .AllowMultiSelect = False
        .filters.Clear
        .Show
        If .SelectedItems.Count > 0 Then
            OutputFolder = .SelectedItems(1) & "\"
        End If
    End With
    Set fd = Nothing
    
    GetFolder = OutputFolder
End Function

5、设置指定区域不能手动编辑

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    'from cell(lrs,lcs) to cell(lre,lce)
    lrs = 14 'start row
    lre = 200 'end row
    lcs = 2 'start column
    lce = 7 'end column
    If Target.Row >= lrs And Target.Row <= lre And Target.Column >= lcs And Target.Column <= lce Then
        'Target.Offset(0, Target.Count - 1).Select
        Range("H" & Target.Row).Select
    End If
End Sub

6、EXCEL在进行筛选后复制可视区域的时候，最多只能选中8192行数据，所以用VBA操作的时候，超过这个数就会报错，在数据量比较大的时候，只能用临时SHEET页来分批（如8000条）处理，再把结果组合起来，以下还包含自动筛选功能及复制筛选结果

'create temp sheet
swb.Sheets.Add after:=swb.Sheets(swb.Sheets.Count)
Set tws = swb.Sheets(swb.Sheets.Count)
sRows = sws.Cells.SpecialCells(xlCellTypeLastCell).Row
sColumns = sws.Cells.SpecialCells(xlCellTypeLastCell).Column
'caculate pages
pCnt = sRows \ 8000
If sRows > 8000 And sRows Mod 8000 > 0 Then
    pCnt = pCnt + 1
End If
'loop to copy data
For p = 0 To pCnt
    tws.UsedRange.Clear
    sws.Range(sws.Cells(p * 8000 + 1, 1), sws.Cells((p + 1) * 8000, sColumns)).Copy tws.Range("A1")
    'tws.Range("A1").PasteSpecial (xlPasteValues)
    tws.AutoFilterMode = False
    tws.Rows(1).AutoFilter
    For c = 1 To cols
        colFilter = Split(arrCol(c - 1), "|")(1)
        If colFilter <> "" Then
            tws.UsedRange.AutoFilter field:=c, Criteria1:=colFilter
        End If
    Next
    pasteLine = ows.UsedRange.Rows.Count + 1
    tws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=ows.Range(ows.Cells(pasteLine, 1), ows.Cells(pasteLine, 1))
    tws.AutoFilterMode = False
Next p
ows.Rows(1).Delete

7、用VBA在处理大文本时，读入的时候不要用adodb.stream或是 FSO的readline，前者是将文件一次性调入内存，我们的文本文件几百M甚至上G，电脑内存受不了，后者在读数据的时候会因为编码的问题丢数据，用以下的方法处理

    Set fso = CreateObject("Scripting.FileSystemObject")
    Open InputFile For Input As #1
    Do While Not EOF(1)
        Line Input #1, txtline
        '........
nextLine:
    Loop
    Close #1

8、打开EXCEL文件下面的文件比Workbooks.Open方法好

Set wb = GetObject(filePath)