Colorful Life2010

Excel中VBA使用的一些总结

最近用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)

 

历史上的今天: [2007/06/27]我们是怎样的一代人[转]
[2005/06/27]今天的芥茉不辣~~

[Excel中VBA使用的一些总结]的回复

Post a Comment~