vba

sammyfun

浏览: 1163472 次
性别:
来自: 西安

最近访客更多访客>>

sdwangyang

this124

单v纯微笑

yeaijun

博主相关

博客

微博

相册

留言

关于我

文章分类

社区版块

存档分类

EXCEL VBA 选择文件夹 2010-08-24 08:23:00| 分类： OFFICE | 标签： |字号大中小订阅 .

进行文件操作时，经常要用VBA选择目标文件夹，现提供几种实现代码：

1.FileDialog 属性
MsoFileDialogType 可为以下 MsoFileDialogType 常量之一。
msoFileDialogFilePicker 允许用户选择一个文件。
msoFileDialogFolderPicker 允许用户选择一个文件夹。
msoFileDialogOpen 允许用户打开一个文件。
msoFileDialogSaveAs 允许用户保存一个文件。

Sub Sample1()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
MsgBox .SelectedItems(1)
'txtFolder.Text = .SelectedItems(1)
End If
End With
End Sub

2.shell 方法
Sub Sample2()
Dim Shell, myPath
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(&O0, "请选择文件夹", &H1 + &H10, "G:\")
If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
Set Shell = Nothing
Set myPath = Nothing
End Sub

3.API 方法
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Sub Sample3()
Dim buf As String
buf = GetFolder("请选择文件夹")
If buf = "" Then Exit Sub
MsgBox buf
End Sub

Function GetFolder(Optional Msg) As String
Dim bInfo As BROWSEINFO, pPath As String
Dim R As Long, X As Long, pos As Integer
bInfo.pidlRoot = 0&
bInfo.lpszTitle = Msg
bInfo.ulFlags = &H1
X = SHBrowseForFolder(bInfo)
pPath = Space$(512)
R = SHGetPathFromIDList(ByVal X, ByVal pPath)
If R Then
pos = InStr(pPath, Chr$(0))
GetFolder = Left(pPath, pos - 1)
Else
GetFolder = ""
End If
End Function

--------------

'存放所有城市区域的数组
Dim arrayArea As Variant

'存放所有excel路径的数组
Dim arrayExcelPath As Variant

Sub Main() '使用双字典，旨在提高速度
    Dim MyName, Dic, Did, i, t, F, TT, MyFileName
       'On Error Resume Next
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
    If Not objFolder Is Nothing Then lj = objFolder.self.Path & "\"
    Set objFolder = Nothing
    Set objShell = Nothing

    t = Time
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add (lj), ""
    i = 0
    Do While i < Dic.Count
        Ke = Dic.keys   '开始遍历字典
        MyName = Dir(Ke(i), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic.Add (Ke(i) & MyName & "\"), "" '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        i = i + 1
    Loop

    For Each Ke In Dic.keys
        MyFileName = Dir(Ke & "*.xls")
        Do While MyFileName <> ""
            Did.Add (Ke & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name = "XLS文件清单" Then
            Sheets("XLS文件清单").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then
        Sheets.Add.Name = "XLS文件清单"
    End If
    mypath = Dic.keys
    arrayArea = Dic.keys
   ' Debug.Print
   '
    ' Debug.Print mypath(0)
   ' For Each ipath In mypath
     '   Debug.Print ipath
   ' Next ipath
    arrayExcelPath = Did.keys
    For i = 0 To Dic.Count
         Debug.Print arrayExcelPath(i)
    Next i

    Dim area As String

    For i = 2 To Dic.Count
         Debug.Print mypath(i - 1)
    Next i


    Sheets("XLS文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)

End Sub

Sub test01()

    Dim myexcel As Application


    Rem 地域处理即表头处理
    For i = 1 To UBound(arrayArea)
          'MsgBox arrayArea(i)
          arr = Split(arrayArea(i), "\")
          MsgBox arr(UBound(arr) - 1)
    Next i

    Rem 具体excel路径
    For i = 0 To UBound(arrayExcelPath)
          'arrayExcelPath(i)是每次循环excel的路径
          MsgBox arrayExcelPath(i)
    Next i

End Sub

Sub test02()

     Application.ScreenUpdating = False

    Application.ShowWindowsInTaskbar = False

    Set MySourceBook = Workbooks.Open("d:\2013343531.xlsx", 0, True)

    Set MySourceSheet = MySourceBook.Worksheets("Sheet1")
MySourceSheet.Activate
MySourceSheet.Cells(1, 3) = "cc"
    MySourceBook.Close False

    Application.ShowWindowsInTaskbar = True

    Application.ScreenUpdating = True


End Sub

Sub testStr()
   Dim str As Variant
   str = "C:\Users\Administrator\Desktop\vba学习\vba demo\data\咸阳\2013343531.xlsx\"
   arr = Split(str, "\")

MsgBox arr(UBound(arr) - 1)
   'For i = 0 To UBound(arr)
       ' MsgBox arr(i)
   ' Next

End Sub

Sub test3()

    Dim excel_App As Excel.Application
    Dim excel_Book As Excel.Workbook
    Dim excel_sheet As Excel.Worksheet

    Set excel_App = CreateObject("Excel.Application")    '引用程序对象实例
    excel_App.Visible = False    '设置Excel为不可见
    '打开文件
    Set excel_Book = excel_App.Workbooks.Open("d:\www.xlsx")      '工作簿实例
    Set excel_sheet = excel_Book.Worksheets("Sheet2")          '数据表实例
    excel_sheet.Range("C1").Value = "你好!"            '设置单元格C1的值为"你好!"

    Set excel_sheet = Nothing
    excel_App.ActiveWorkbook.Close savechanges:=True    '保存对EXCELL进行更改。
    Set excel_Book = Nothing
    excel_App.Quit
    Set excel_App = Nothing

End Sub

Sub test4()

    Dim excel_App As Excel.Application
    Dim excel_Book As Excel.Workbook
    Dim excel_sheet As Excel.Worksheet
    Dim colunm As Variant

    Set excel_App = CreateObject("Excel.Application")    '引用程序对象实例
    excel_App.Visible = False    '设置Excel为不可见
    '打开文件
    Set excel_Book = excel_App.Workbooks.Open("C:\Users\Administrator\Desktop\vba学习\vba demo\data\咸阳\2013343531.xlsx")      '工作簿实例
    Set excel_sheet = excel_Book.Worksheets("Sheet1")          '数据表实例
    excel_sheet.Unprotect
     ActiveSheet.Range("A1:G1") = excel_sheet.Range("A1:G1")


    Set excel_sheet = Nothing
    excel_App.ActiveWorkbook.Close savechanges:=True    '保存对EXCELL进行更改。
    Set excel_Book = Nothing
    excel_App.Quit
    Set excel_App = Nothing

End Sub

给出两个方法：
1. 在代码行 “Sheets(1).Range("A1").Select ”
之前加下面这个语句
Sheets(1).activate

2. Sheets(1).Range("A1").Select    改为 application.goto Sheets(1).Range("A1")

Sheets("Sheet3").Range("B1:B7").Copy
            Sheets("Sheet1").Range("B9:B15").Select
            ActiveSheet.Paste

333333333333333333333333333333333
我已经做了一个excel表格，我现在用的是最笨的方法，就是用了辅助的表格，把路径上的数据表一个个打开，贴到辅助表中，再关闭。处理得很慢。我想能不能不用辅助数据表，直接后台对路径上的excel文件读取数据呢？各位大侠帮帮忙吧。还有个小问题，下面的Observation1!，就是我建的辅助表，我现在要在指定单元格里面输出对辅助表中数据计算的值，如果没有辅助表，直接从路径上读取数据，这个countifs该怎么写呢。=COUNTIFS(Observation1!B:B,"*s*",Observation1!AG:AG,start!B1) 问题补充：
说简单点，请看代码Dim a As Stringa = Application.WorksheetFunction.CountIfs(Worksheets("Observation1").Range("AG:AG"), Worksheets("start").Range("B1"))Sheet4.Cells(2, 6).Value = a现在这个observation1这个sheet是我建的辅助表，从D：\ 打开，然后粘贴过来的。现在我想不打开，直接引用数据的话，这段程序该怎么改呢。不要打开引用数据的文件，不然速度实在太慢了。我来帮他解答
推荐答案 2012-04-20 12:37 只能给你个几个参考，当然还有其他方法，希望能够帮到你望采纳 getobject函数本质是打开的，只是看不到窗口 Dim wb as workbook   set wb = getobject(具体路径+文件)       with wb           .............(operation on wb)       end with wb.close false set wb=nothing追问有没有不打开的方法啊，由于数据表很大，打开的话运行速度太慢了，谢谢你了！补充问题，请看代码Dim a As Stringa = Application.WorksheetFunction.CountIfs(Worksheets("Observation1").Range("AG:AG"), Worksheets("start").Range("B1"))Sheet4.Cells(2, 6).Value = a现在这个observation1这个sheet是我建的辅助表，从D：\ 打开，然后粘贴过来的。现在我想不打开，直接引用数据的话，这段程序该怎么改呢回答不要纠结于打不打开表了，程序内部肯定是需要进行访问目标表的理论上，程序还是需要载入目标表内容的，不然怎么进行处理呢你不知道excel的源代码，是不可能做到直接去解析他的数据存储更何况你是用excel的vba来处理excel自己的数据，他当然用他自己的方式访问目标表在屏幕上显示或不显示打开的表只是一种形式过程无论所谓的打开和不打开表，本质上计算机都要进行载入操作的文件。可能你会觉得某些隐藏表，或者屏幕不显示表的方式会快一点，那是因为Screenupdate的速度肯定要比你机器内部处理速度要慢，隐藏或屏蔽了显示的处理过程，会是速度相对提高点赞同2|评论(1)
求助知友Ronnie0812 | 当前分类：18 级排名：633

擅长办公软件：18 级排名：633 |来自团队Excel粉丝
按默认排序|按时间排序
其他回答共4条
2012-04-24 13:36zhaochang168|当前分类：2 级
楼上说的是对的，不可能不打开，要读取excel数据，必须要打开excel进程，并读入文件数据只不过可以让进程在后台运行，看不到罢了赞同0|评论 2012-04-25 09:37燕翩然|当前分类：3 级
可以把辅助表，做成模板，然后在宏中加入到当前文件中，用后再删除，应该能快点