谢谢分享

VBA文件及文件夹操作
1.VBA操作文件及文件夹
on error resume next下测试

A，在D：\下新建文件夹，命名为folder

方法1：MkDir "D：\folder"

方法2：Set abc = CreateObject("Scripting.FileSystemObject")

abc.CreateFolder ("D：\folder")

B，新建2个文件命名为a.xls和b.xls

Workbooks.Add

ActiveWorkbook.SaveAs Filename：="D：\folder\a.xls"

ActiveWorkbook.SaveAs Filename：="D：\folder\b.xls"

C,创建新文件夹folder1并把a.xls复制到新文件夹重新命名为c.xls

MkDir "D：\folder1"

FileCopy "D：\folder\a.xls", "D：\folder1\c.xls"

D,复制folder中所有文件到folder1

Set qqq = CreateObject("Scripting.FileSystemObject")

qqq.CopyFolder "D：\folder", "D：\folder1"

D,重命名a.xls为d.xls

name "d：\folder1\a.xls" as "d：\folder1\d.xls"

E,判断文件及文件夹是否存在

Set yyy = CreateObject("Scripting.FileSystemObject")

If yyy.FolderExists("D：\folder1) = True Then ...

If yyy.FileExists("D：\folder1\d.xls) = True Then ...

F,打开folder1中所有文件

Set rrr = CreateObject("Scripting.FileSystemObject")

Set r = rrr.GetFolder("d：\folder1")

For Each i In r.Files

Workbooks.Open Filename：=("d：\folder1\" + i.Name + "")

Next

G,删除文件c.xls

kill "d：\folder1\c.xls"

H,删除文件夹folder

Set aaa = CreateObject("Scripting.FileSystemObject")

aaa.DeleteFolder "d：\folder"

2.excel vba一次性获取文件夹下的所有文件名的方法
小生今天上网下载了一个财务常用报表的文件包，里面有几百个excel工作表，要是手工一个一个的获得文件名的话，那我可是要忙十天半月哦。于是想到昨论 坛就是vba论坛，昨不充分利用excel 自身的高级应用呀，呵呵，实现的代码如下，把工作量几天的任务可是一下子就完成了，这就是excel vba给你工作提高效率的结果！

excle vba自动获取同一文件夹下所有工作表的名称红色代码：

按Alt+F11，打开VBA编辑器，插入一个模块，把下面的代码贴进去，按F5执行

Sub t()

Dim s As FileSearch '定义一个文件搜索对象

Set s = Application.FileSearch

s.LookIn = "c：\" '注意路径，换成你实际的路径

s.Filename = "*.*" '搜索所有文件

s.Execute '执行搜索

Cells.Delete '表格清空

For i = 1 To s.FoundFiles.Count

Cells(i, 1) = s.FoundFiles(i) '每一行第一列填写一个文件名

Next

End Sub

现在获得的可是带路径的工作表名，去掉前的路径可用以下方法；

=RIGHT(A1,LEN(A1)-FIND("#",SUBSTITUTE(A1,"\","#",LEN(A1)-LEN(SUBSTITUTE(A1,"\",)))))

最后用常规的方法往下拖，就完成了笔者所需的工作表名。

outlook下VBA编程：把公用文件夹里的邮件附件拷贝出来保存在硬盘上

2009-06-17 09：35

Sub SaveAttachments()

Dim oApp As Outlook.Application

Dim oNameSpace As NameSpace

Dim oFolder As MAPIFolder

Dim oMailItem As Object

Dim sMessage As String

BeforeDate = #10/1/2007#     ' choose the end date of wanted

MyDir = "E：\liuxc-work\oil loss\backup from public folder\"   ' choose the folder location for save

Sender = "Hz121 Supervisor"   ' caution, case sensitive

SendFile = "HZ121-1_Daily.xls"

MyY = 0

Set oApp = New Outlook.Application

Set oNameSpace = oApp.GetNamespace("MAPI")

Set oFolder = oNameSpace.PickFolder

For Each oMailItem In oFolder.Items

With oMailItem

MyT3 = Left(CStr(oMailItem.CreationTime), 10)

If CDate(oMailItem.CreationTime) >= BeforeDate Then

If oMailItem.SenderName = Sender Then

If oMailItem.Attachments.Count > 0 Then ' protect error

For i = 1 To oMailItem.Attachments.Count

If oMailItem.Attachments.Item(i).FileName = SendFile Then

MyT1 = InStr(1, oMailItem.Attachments.Item(i).FileName, ".", 1)

MyT2 = Left(oMailItem.Attachments.Item(i).FileName, 19) + "-" + MyT3 + ".xls"

oMailItem.Attachments.Item(i).SaveAsFile MyDir & MyT2

MsgBox oMailItem.Attachments.Item(i).DisplayName & " was saved as " & oMailItem.Attachments.Item(i).FileName

End If

Next i

End If

End If

Else

MyY = MyY + 1

If MyY > 10 Then GoTo LoopEnd

End If

End With

Next oMailItem

LoopEnd：

' Set oMailItem = Nothing

' Set oFolder = Nothing

' Set oNameSpace = Nothing

' Set oApp = Nothing

3.Excel VBA把选定文件夹中的工作簿导入到新建ACCESS数据库中
2010-04-24 22：33

方法一

Sub Create_AccessProject()

Dim AccessData As Object

Set AccessData = CreateObject("Access.Application")

Dim Stpath As String

Stpath = ThisWorkbook.Path & "\DSEM-Stock-Allocation.mdb" '设定路径

If Dir(Stpath, vbDirectory) = "DSEM-Stock-Allocation.mdb" Then

Kill (Stpath)

End If

AccessData.NewCurrentDatabase Stpath

Set AccessData = Nothing '创建表格

Set cnnaccess = CreateObject("Adodb.Connection")

Set rstAnswers = CreateObject("Adodb.Recordset")

cnnaccess.Provider = "Microsoft.Jet.OLEDB.4.0"

Application.Wait Now() + TimeValue("00：00：02") '系统暂停2秒,以等待data.mdb建立成功

cnnaccess.Open "Data Source =" & Stpath & ";Jet OLEDB：Database Password=" & ""

'strSQL = "Create Table myData(last_date char(8))"

'rstAnswers.Open strSQL, cnnaccess

Set rstAnswers = Nothing

Set cnnaccess = Nothing

MyMainFile = ThisWorkbook.Name

Dim CurFile As String

Application.DisplayAlerts = False

myFile = Application.GetOpenFilename("(*.xls),*.xls)", , "Please Select Files")

If myFile = False Then Exit Sub

DirLoc = CurDir(myFile) & "\"

CurFile = Dir(DirLoc & "*.xls")

Do While CurFile <> vbNullString

Set objAccess = CreateObject("Access.Application")

LinkFile = DirLoc & CurFile

TableName = Left(CurFile, Len(CurFile) - 4)

If CurFile = "HONHAI-VMIData1.xls" Then

With objAccess

.OpenCurrentDatabase (ThisWorkbook.Path & "\DSEM-Stock-Allocation.mdb")

.DoCmd.TransferSpreadsheet acLink, 8, TableName, LinkFile, True, "Aging Report$"

End With

objAccess.CloseCurrentDatabase

Set objAccess = Nothing

CurFile = Dir

Else

With objAccess

.OpenCurrentDatabase (ThisWorkbook.Path & "\DSEM-Stock-Allocation.mdb")

.DoCmd.TransferSpreadsheet acImport, 8, TableName, LinkFile, True, ""

End With

objAccess.CloseCurrentDatabase

Set objAccess = Nothing

CurFile = Dir

End If

Loop

End Sub

方法二

Sub Folder2Access()

Dim db As DAO.Database

Dim ws As DAO.Workspace

Set ws = DBEngine.Workspaces(0)

Set db = ws.OpenDatabase("C：\CustomersDataBase\DSEM-PO-Stock-Status.mdb", False, False, "")

db.Execute ("delete * from [DSEM-MovingPlan]")

db.Close

Set db = Nothing

Dim myFile As String

Dim s As FileSearch '定义一个文件搜索对象

Set s = Application.FileSearch

s.LookIn = "C：\CustomersDataBase\Test\" '注意路径，换成你实际的路径

s.Filename = "*.*" '搜索所有文件

s.Execute '执行搜索

For i = 1 To s.FoundFiles.Count

FullName1 = Right(s.FoundFiles(i), Len(s.FoundFiles(i)) - Len("C：\CustomersDataBase\Test\"))

Filename = Left(FullName1, Len(FullName1) - 4)

Set objAccess = CreateObject("Access.Application")

myFile = "C：\CustomersDataBase\Test\" & Filename & ".xls"

With objAccess

.OpenCurrentDatabase ("C：\CustomersDataBase\DSEM-PO-Stock-Status.mdb")

.DoCmd.TransferSpreadsheet acImport, 8, "DSEM-MovingPlan", myFile, True, ""

End With

objAccess.CloseCurrentDatabase

Set objAccess = Nothing

Next

End Sub

4.vba操作文件及文件夹示例
2009-08-20 00：07

vba操作文件及文件夹示例

利用excel中的vba可以对电脑中的文件及文件夹做一些常用的操作。

包括复制、重命名、删除等，其中一些简单的示例总结如下。

希望对一些经常需要批量处理文件的朋友有所帮助，也希望感兴趣的朋友多多指教！以下代码建议在on error resume next下测试

1，在D：\下新建文件夹，命名为folder

方法1：MkDir "D：\folder"

方法2：Set abc = CreateObject("Scripting.FileSystemObject")

abc.CreateFolder ("D：\folder")

2，新建2个文件命名为a.xls和b.xls

Workbooks.Add

ActiveWorkbook.SaveAs Filename：="D：\folder\a.xls"

ActiveWorkbook.SaveAs Filename：="D：\folder\b.xls"

3,创建新文件夹folder1并把a.xls复制到新文件夹重新命名为c.xls

MkDir "D：\folder1"

FileCopy "D：\folder\a.xls", "D：\folder1\c.xls"

4,复制folder中所有文件到folder1

Set qqq = CreateObject("Scripting.FileSystemObject")

qqq.CopyFolder "D：\folder", "D：\folder1"

5,重命名a.xls为d.xls

name "d：\folder1\a.xls" as "d：\folder1\d.xls"

6,判断文件及文件夹是否存在

Set yyy = CreateObject("Scripting.FileSystemObject")

If yyy.FolderExists("D：\folder1) = True Then ...

If yyy.FileExists("D：\folder1\d.xls) = True Then ...

7,打开folder1中所有文件

Set rrr = CreateObject("Scripting.FileSystemObject")

Set r = rrr.GetFolder("d：\folder1")

For Each i In r.Files

Workbooks.Open Filename：=("d：\folder1\" + i.Name + "")

Next 8,删除文件c.xls

kill "d：\folder1\c.xls" 9,删除文件夹folder

Set aaa = CreateObject("Scripting.FileSystemObject")

aaa.DeleteFolder "d：\folder"

VBA Dir 函数 遍历文件夹下的所有文件

2010-05-26 17：30