批量读取数据源文件
按内容拆分不同文件，分发在保存不同路径下
对处理完成的数据源进行归档
------------------------------------------------------------------------
Global fso
Sub DistributeBillings()
'get source files' folder path
sfp = Sheet2.Cells(1, 2)
If Len(sfp) = 0 Then sfp = ThisWorkbook.Path
If Right(sfp, 1) <> "\" Then sfp = sfp & "\"
'get archive folder path
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.folderexists(sfp & "Archive") Then fso.CreateFolder (sfp & "Archive")
afp = sfp & "Archive\"
'create dictionary of matrix
Set dd = CreateObject("Scripting.Dictionary")
arr = Sheet2.Cells(3, 1).Resize(Sheet2.[A1000000].End(xlUp).Row - 2, 2)
For i = 1 To UBound(arr, 1)
If Right(arr(i, 2), 1) <> "\" Then arr(i, 2) = arr(i, 2) & "\"
dd(arr(i, 1)) = arr(i, 2)
Next
'remove old sheets, if any
Application.DisplayAlerts = False
For i = Sheets.Count To 3 Step -1
Sheets(Sheets.Count).Delete
Next
'get list of all source files
Sheet1.Range("A2").Resize(10000, 14).ClearContents
GetAllFiles (sfp)
For i = 2 To Sheet1.[A100000].End(xlUp).Row
'open one of souce files
ff = Sheet1.Cells(i, 1)
fn = fso.GetFileName(ff)
Set wb = Workbooks.Open(ff)
' check if exist non-registered company code
rs = ActiveSheet.Cells(10000, 9).End(xlUp).Row
For x = 2 To rs
If Not dd.exists(ActiveSheet.Cells(x, 9).Value) Then
MsgBox "File：" & fn & " Code：º " & ActiveSheet.Cells(x, 9).Value & " is not existed in distribution matrix，retry after update it please！"
wb.Close
GoTo ex
End If
Next
' copy source file data to sheet
For x = 2 To rs
Notes = wb.Sheets(1).Cells(x, 9).Value
If Not Exist(Notes) Then
ThisWorkbook.Activate
Set st = Sheets.Add(After:=Sheets(Sheets.Count))
st.Name = Notes
wb.Sheets(1).[A1:AG1].Copy st.[A1]
Else
Set st = Sheets(Notes)
End If
wb.Sheets(1).Cells(x, 1).Resize(1, 33).Copy st.[A100000].End(xlUp)(2)
DoEvents
Next
wb.Close
' save sheet to file
For c = 3 To Sheets.Count
sn = Sheets(c).Name
Sheets(c).Copy
tf = dd(sn) & fn
ActiveWorkbook.SaveAs Filename:=tf
ActiveWorkbook.Close
DoEvents
Next
'archive source file
fso.CopyFile ff, afp
Kill ff
For c = Sheets.Count To 3 Step -1
Sheets(Sheets.Count).Delete
Next
ex:
Next
Application.DisplayAlerts = True
End Sub
Function GetAllFiles(fp$)
Dim fn, n
n = Dir(fp & "\")
Do While Len(n) <> 0
If UCase(n) Like "*.XLS" Or UCase(n) Like "*.XLSX" Then
Sheet1.[A65536].End(3)(2) = fp & "\" & n
Sheet1.Hyperlinks.Add anchor:=Sheet1.[A65536].End(3)(1), Address:=fp & "\" & n
End If
n = Dir
Loop
For Each fn In fso.getfolder(fp).subfolders
GetAllFiles (fn)
Next
End Function
Function Exist(sht) As Boolean
Exist = False
For Each s In Sheets
If s.Name = sht Then
Exist = True
Exit For
End If
Next
End Function
案例下载：https://pan.baidu.com/s/1sGfG5QZ5smcQADLXfh843A?pwd=t18q
此例多次使用FSO对象的方法，参见此贴 https://tieba.baidu.com/p/8848588841 的 91楼
按内容拆分不同文件，分发在保存不同路径下
对处理完成的数据源进行归档
------------------------------------------------------------------------
Global fso
Sub DistributeBillings()
'get source files' folder path
sfp = Sheet2.Cells(1, 2)
If Len(sfp) = 0 Then sfp = ThisWorkbook.Path
If Right(sfp, 1) <> "\" Then sfp = sfp & "\"
'get archive folder path
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.folderexists(sfp & "Archive") Then fso.CreateFolder (sfp & "Archive")
afp = sfp & "Archive\"
'create dictionary of matrix
Set dd = CreateObject("Scripting.Dictionary")
arr = Sheet2.Cells(3, 1).Resize(Sheet2.[A1000000].End(xlUp).Row - 2, 2)
For i = 1 To UBound(arr, 1)
If Right(arr(i, 2), 1) <> "\" Then arr(i, 2) = arr(i, 2) & "\"
dd(arr(i, 1)) = arr(i, 2)
Next
'remove old sheets, if any
Application.DisplayAlerts = False
For i = Sheets.Count To 3 Step -1
Sheets(Sheets.Count).Delete
Next
'get list of all source files
Sheet1.Range("A2").Resize(10000, 14).ClearContents
GetAllFiles (sfp)
For i = 2 To Sheet1.[A100000].End(xlUp).Row
'open one of souce files
ff = Sheet1.Cells(i, 1)
fn = fso.GetFileName(ff)
Set wb = Workbooks.Open(ff)
' check if exist non-registered company code
rs = ActiveSheet.Cells(10000, 9).End(xlUp).Row
For x = 2 To rs
If Not dd.exists(ActiveSheet.Cells(x, 9).Value) Then
MsgBox "File：" & fn & " Code：º " & ActiveSheet.Cells(x, 9).Value & " is not existed in distribution matrix，retry after update it please！"
wb.Close
GoTo ex
End If
Next
' copy source file data to sheet
For x = 2 To rs
Notes = wb.Sheets(1).Cells(x, 9).Value
If Not Exist(Notes) Then
ThisWorkbook.Activate
Set st = Sheets.Add(After:=Sheets(Sheets.Count))
st.Name = Notes
wb.Sheets(1).[A1:AG1].Copy st.[A1]
Else
Set st = Sheets(Notes)
End If
wb.Sheets(1).Cells(x, 1).Resize(1, 33).Copy st.[A100000].End(xlUp)(2)
DoEvents
Next
wb.Close
' save sheet to file
For c = 3 To Sheets.Count
sn = Sheets(c).Name
Sheets(c).Copy
tf = dd(sn) & fn
ActiveWorkbook.SaveAs Filename:=tf
ActiveWorkbook.Close
DoEvents
Next
'archive source file
fso.CopyFile ff, afp
Kill ff
For c = Sheets.Count To 3 Step -1
Sheets(Sheets.Count).Delete
Next
ex:
Next
Application.DisplayAlerts = True
End Sub
Function GetAllFiles(fp$)
Dim fn, n
n = Dir(fp & "\")
Do While Len(n) <> 0
If UCase(n) Like "*.XLS" Or UCase(n) Like "*.XLSX" Then
Sheet1.[A65536].End(3)(2) = fp & "\" & n
Sheet1.Hyperlinks.Add anchor:=Sheet1.[A65536].End(3)(1), Address:=fp & "\" & n
End If
n = Dir
Loop
For Each fn In fso.getfolder(fp).subfolders
GetAllFiles (fn)
Next
End Function
Function Exist(sht) As Boolean
Exist = False
For Each s In Sheets
If s.Name = sht Then
Exist = True
Exit For
End If
Next
End Function
案例下载：https://pan.baidu.com/s/1sGfG5QZ5smcQADLXfh843A?pwd=t18q
此例多次使用FSO对象的方法，参见此贴 https://tieba.baidu.com/p/8848588841 的 91楼
