合并表格并将文件名称放入首列

Michael.Deng

合并表格的代码我有将文件名称放入首列的代码我也有
就是不知道怎么将代码合并在一起

功能需求如下：
有N个表格名称为表一、表二、表三、表四、表五的表格；将表格名称添加至对应的表格后，再将他们进行合并。如附件所示

Michael.Deng

问题自己解决了，平均运行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

Michael.Deng

合并表格的代码如下：
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
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

Michael.Deng

将文件名称放入首列的代码如下：
Sub 宏1()
    i = ActiveSheet.Cells([A100000].End(xlUp).Row, 1).Row
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Dim STR
    STR = ThisWorkbook.Name
    y = Mid(STR, 1, InStr(STR, ".") - 1)
    Range("A1:A" & i) = y
   
End Sub

xiangbaoan

………………

Michael.Deng

xiangbaoan 发表于 2019-6-13 13:26
………………

感谢回复，不能满足需求（我希望合并的文件不止只有2列）

xiangbaoan

Michael.Deng 发表于 2019-6-13 14:30
感谢回复，不能满足需求（我希望合并的文件不止只有2列）

1、首先，只提供1列原始数据，模拟数据也只有两列；模拟数据也该稍稍完整一点吧?不然就多说明一下难道不行??
2、其次，只改一点点就行了，不会动手吧?
sql = "SELECT '" & Split(fil.Name, ".")(0) & "',* FROM " & st & "[$A1:Az] WHERE NOT F1 IS NULL"

Michael.Deng

xiangbaoan 发表于 2019-6-13 14:53
1、首先，只提供1列原始数据，模拟数据也只有两列；模拟数据也该稍稍完整一点吧?不然就多说明一下难道不 ...

感谢耐心回复，确实我做的附件不够好。然后根据你的调整了之后，现在变得很卡，已经卡了7-8分钟了，还没有好，但是还是真心感谢你@

xiangbaoan

Michael.Deng 发表于 2019-6-13 16:38
感谢耐心回复，确实我做的附件不够好。然后根据你的调整了之后，现在变得很卡，已经卡了7-8分钟了，还没 ...

………………

Michael.Deng

xiangbaoan 发表于 2019-6-13 17:15
………………

我要合并的数据是20万行的，87个工作表，、、、、、、、