请教,汇总多个文件夹固定单元格数据,引用高手的代码如下,提示错误400,请教各位高手帮帮忙。
Sub 汇总数据()
Dim arr, brr, i&, m&, k%, bookName$, wb As Workbook
k = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count
ReDim brr(1 To k, 1 To 8)
m = 1
arr = Array("文件名称", "销售单号", "打印日期", "合约编号", "项目名称", "单位", "金额", "经办人")
For i = 0 To UBound(arr)
brr(m, i + 1) = arr(i)
Next
Application.ScreenUpdating = False
Dim mPath As String: mPath = ThisWorkbook.Path & "\"
Dim mFile As String: mFile = Dir(mPath & "*.xls")
Do
If mFile <> ThisWorkbook.Name Then
Set wb = GetObject(mPath & mFile)
With wb
arr = .Worksheets(1).Range("Al").CurrentRegion.Value
bookName = Split(.Name, ".")(0)
.Close False
End With
m = m + 1
brr(m, 1) = bookName
brr(m, 2) = mTrim(arr(2, 11))
brr(m, 3) = arr(3, 11)
brr(m, 4) = arr(4, 11)
brr(m, 5) = arr(2, 5)
brr(m, 6) = mTrim(arr(5, 3))
brr(m, 7) = arr(8, 9)
brr(m, 8) = arr(12, 10)
End If
mFile = Dir
Loop While mFile <> Empty
If m = 1 Then Exit Sub
With ActiveSheet
.Cells.Clear
.Range("Al").Resize(m, 8).Value = brr
With .UsedRange
.Borders.LineStyle = 1
.Rows.AutoFit
.Columns.AutoFit
End With
.Columns("B:H").HorizontalAlignment = xlCenter
.Range("A1:H1").Interior.Colorlndex = 6
End With
Application.ScreenUpdating = True
MsgBox "OK"
End Sub
Public Function mTrim(mStr) As String
mStr = Application.Clean(mStr)
mStr = VBA.Replace(mStr, Chr(0), Empty)
mStr = VBA.Replace(mStr, Chr(10), Empty)
mStr = VBA.Replace(mStr, Chr(13), Empty)
mStr = VBA.Replace(mStr, Chr(32), Empty)
mStr = VBA.Replace(mStr, Chr(127), Empty)
mStr = VBA.Replace(mStr, "", Empty)
mStr = VBA.Replace(mStr, "", Empty)
mTrim = mStr
End Function
只有本站会员才能查看附件,请 登录