感谢论坛大佬

bdsajb

Sub 合并当前目录下所有工作簿的全部工作表()
2 G% D7 v) w2 |+ L# V
Dim MyPath, MyName, AWbName
7 C" X8 V  \( d" m# ^
Dim Wb As Workbook, WbN As String

# |9 [1 \- @7 x4 k  C1 q" MDim G As Long
% {# ~# \) R" i# D
$ [  `# _4 B4 W3 u) h9 ^Dim Num As Long
0 r1 o( o8 D1 m4 ^  w/ j/ e  @# H& g
. O! x; v/ i$ F/ }' N) ~* J2 }5 bDim BOX As String

Application.ScreenUpdating = False
  K* X7 O" d* b" Z* b$ i. x
! r( Y+ a$ o# B) o6 A' kMyPath = ActiveWorkbook.Path
7 ~( q/ U6 t; q2 o* S% }
MyName = Dir(MyPath & "\" & "*.xls")
/ D, j: P) S0 D1 m
AWbName = ActiveWorkbook.Name
! Z, A2 `) f# |6 ]
* }) ?+ y' ]: C, K+ g/ e- KNum = 0

Do While MyName <> ""
% t) l3 Y9 P4 @7 G( ?4 ^: B3 D1 e
6 N  L* A: X: W% \( b! vIf MyName <> AWbName Then

Set Wb = Workbooks.Open(MyPath & "\" & MyName)
  G7 J  o$ y' A( P' P  H
Num = Num + 1
! P( r/ }: a; t% [
% b7 ?  N8 h! V+ r! cWith Workbooks(1).ActiveSheet
, N/ \, E& ^) N6 x$ ?% k6 `
  {, }. E& c/ J/ m3 B.Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)

For G = 1 To Sheets.Count
0 F( K  t+ [2 @
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
6 f) ~" `0 F; W- e! w& n& N
! |3 S0 h. A+ @% y8 U0 \Next
2 S9 K+ X3 g3 ~& T1 s
, Q2 Z$ n* @4 c; h: A3 x% I' uWbN = WbN & Chr(13) & Wb.Name
$ Q. {7 [4 }# M* l" {& J
+ ^; K' f) D4 r; xWb.Close False

- e5 S2 @! g* a/ x8 r, o+ Y- CEnd With
4 ]' @& d0 N4 L
- a4 b# H1 I* [2 ~3 G- n) k) Z7 H' rEnd If
. g+ t# l; u/ V: ?
' A9 ]: a2 a% j0 t. [' R3 lMyName = Dir

) W" x' C( R/ R7 \$ G, X' `Loop

Range("B1").Select
, Q: l: }  s4 z! @8 q% Z
. U# |/ C* S1 h. Y# q6 G) xApplication.ScreenUpdating = True
* K, a% _5 Z# J, }
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
* H0 b3 T( {% K* a/ }4 {. t
End Sub