|
楼主 |
发表于 2019-6-14 14:23
|
显示全部楼层
本帖最后由 Michael.Deng 于 2019-6-15 08:31 编辑
问题自己解决了,平均运行3分钟,算法很蠢,源码如下:(不知道能不能申请加精)
Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xlsx") '文件类型
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("A1000000").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To 1
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A1000000").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Dim LastRow As Long
If WorksheetFunction.CountA(Cells) > 0 Then
LastRow = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
For a = LastRow To 1 Step -1
If Cells(a, 2) = "" Then
Exit For
End If
Next
For i = 1 To LastRow
If Cells(i, 2) = "" Then
Cells(i, 2) = 1
If i >= a Then
j = LastRow + 1
Else: j = Columns("B:B").SpecialCells(xlCellTypeBlanks).Cells(1, 1).Row
End If
Range(Cells(i + 2, 1), Cells(j - 1, 1)) = Cells(i + 1, 2)
End If
Next
Range("A1").Select
Application.ScreenUpdating = True
End Sub
|
|