新浪博客

VBA打开文件夹下所有excel文件并复制数据

2010-10-10 19:21阅读:
打开文件夹下所有excel文件并复制数据,对于已存在的数据进行更新,对于新数据进行添加。
Sub copydata()
Dim strFolder As String
Dim varFileList As Variant
Dim FSO As Object, myFile As Object
Dim myResults As Variant
Dim l As Long
'显示打开文件夹对话框
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub '未选择文件夹
strFolder = .SelectedItems(1)
End With
'获取文件夹中的所有文件列表
varFileList = fcnGetFileList(strFolder)
If Not IsArray(varFileList) Then
MsgBox '未找到文件', vbInformation
Exit Sub
End If
'获取文件的详细信息,并放到数组中
ReDim myResults(0 To UBound(varFileList) + 1, 0 To 5)
myResults(0, 0) = '文件名'
Set FSO = CreateObject('Scripting.FileSystemObject')
For l = 0 To UBound(varFileList)
Set myFile = FSO.GetFile(CStr(varFileList(l)))
myResults(l + 1, 0) = CStr(varFileList(l))
Workbooks.Open (myResults(l + 1, 0))
Dim arr(0 To 100, 0 To 100) As String
'获取文件中的数据给二维数组赋值
F
or row2 = 6 To 100
For col2 = 1 To 20
arr(row2 - 6, col2 - 1) = Cells(row2, col2)
Next col2
Next row2
ActiveWorkbook.Close
'打开总表
Windows('2010_PCMO_表格.xls').Activate
'撤消保护工作表
ActiveSheet.Unprotect '371021'
'获取总表中不为空的行数
Dim m As Integer
Dim n As Integer
m = 5
For n = 6 To 200
If Cells(n, 1) <> '' Then
m = m + 1
End If
Next n
'向总表中添加数据
For row3 = 0 To 20
'删除已存在的数据
For row4 = 6 To m
If arr(row3, 5) = Cells(row4, 6) Then
Cells(row4, 1).Select
Selection.EntireRow.Delete
m = m - 1
End If
Next row4
'添加数据
For col3 = 1 To 20
Cells(m + 1, col3) = arr(row3, col3 - 1)
Next col3
m = m + 1
Next row3
'更改序号
For num = 6 To 200
If Cells(num, 1) <> '' Then
Cells(num, 1) = num - 5
End If
Next num
'保护工作表并设置密码
ActiveSheet.Protect '371021'
ActiveWorkbook.Save
Next l
Set myFile = Nothing
Set FSO = Nothing
End Sub
Private Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant
' 如果文件夹中包含文件返回一个二维数组,否则返回False
Dim f As String
Dim i As Integer
Dim FileList() As String
If strFilter = '' Then strFilter = '*.*'
Select Case Right$(strPath, 1)
Case '', '/'
strPath = Left$(strPath, Len(strPath) - 1)
End Select
ReDim Preserve FileList(0)
f = Dir$(strPath & '' & strFilter)
Do While Len(f) > 0
ReDim Preserve FileList(i) As String
FileList(i) = f
i = i + 1
f = Dir$()
Loop
If FileList(0) <> Empty Then
fcnGetFileList = FileList
Else
fcnGetFileList = False
End If
End Function

我的更多文章

下载客户端阅读体验更佳

APP专享