|
Sub 首师()
Application.ScreenUpdating = False
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Dim ar As Variant, br As Variant
Dim ks As Long
Dim cr()
With Sheet1
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r > 2 Then
ks = .Cells(Rows.Count, 1).End(xlUp)
ar = .Range("a2:g" & r)
.Range("g3:g" & r) = ""
For i = 2 To UBound(ar)
If ar(i, 2) <> "" Then
d(ar(i, 2)) = i
End If
Next i
End If
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "----------请选中一个或多个文件:" '选择框标题名称
.InitialFileName = ThisWorkbook.Path & "\"
.Filters.Clear
.Filters.Add "选择Excel文件", "*.xls,*.xlsx,", 1 '查找目录下的xls和xlsx文件
If .Show = 0 Then
MsgBox "本次没有选择任何文件"
Exit Sub
End If
Set 文件集合 = .SelectedItems
End With
ReDim cr(1 To 50000, 1 To 7)
For Each 文件名 In 文件集合 '依次找寻指定路径中的*.xls文件,当指定路径中有文件时进行循环
If Not 文件名 Like ThisWorkbook.Name Then '就执行后面的代码
Set ak = GetObject(文件名)
trow = ThisWorkbook.Sheets(1).Range("b65536").End(xlUp).Row '导入前汇总表的总行数
rs = ak.Sheets(1).Range("b65536").End(xlUp).Row '分表的总行数
br = ak.Sheets(1).Range("a2:f" & rs)
ak.Close False
For i = 2 To UBound(br)
If br(i, 2) <> "" Then
xh = d(br(i, 2))
If xh <> "" Then
For j = 3 To UBound(br, 2)
ar(xh, j) = br(i, j)
Next j
ar(xh, 7) = "导入成功"
Else
n = n + 1
For j = 2 To UBound(br, 2)
cr(n, j) = br(i, j)
Next j
cr(n, 1) = ks + n
cr(n, 7) = "导入成功"
End If
End If
Next i
End If
Next
.Range("a2:g" & r) = ar
.Range("a2:g" & r).Borders.LineStyle = 1
If n <> "" Then .Cells(r + 1, 1).Resize(n, UBound(cr, 2)) = cr: .Cells(r + 1, 1).Resize(n, UBound(cr, 2)).Borders.LineStyle = 1
End With
Set 文件名 = Nothing
Set 文件集合 = Nothing
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|