-
- Excel中VBA使用的一些总结
- 2012-06-27
最近用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)
-
Views(6553) | Comments(0) |
In:
System/Application
Work+Study
|

VBProject:代码操作代码之常用语句 (转)
(07/16)
