PTShare - 乐享影视 让小水管也玩得起PT!

 找回密码
 立即注册
搜索
查看: 402|回复: 0

感谢论坛大佬

[复制链接]
  • TA的每日心情
    难过
    2020-11-4 15:03
  • 签到天数: 4 天

    [LV.2]偶尔看看I

    发表于 2020-7-6 10:05:41 | 显示全部楼层 |阅读模式
    Sub 合并当前目录下所有工作簿的全部工作表()
    9 J2 H2 j% ?' o4 k8 ]3 U$ Q
    4 p) n  Z6 i( ]+ \Dim MyPath, MyName, AWbName$ n9 S' L9 B) `  m9 G
      ]/ N3 W% z& S; B0 P
    Dim Wb As Workbook, WbN As String$ A  p7 Q, V; B& J/ l1 j# n' B7 f
    9 f' G/ i  f5 @* o# U) |6 p$ M
    Dim G As Long
    : D6 E' \% [/ _, @- g6 ?
    ) i6 D+ B) |2 x- }4 K( K+ GDim Num As Long6 F: t) e2 E0 l6 u  |9 k
    ; V5 g3 n0 g( ?& ^) {
    Dim BOX As String
    ! C8 z  P* X  }9 }6 t& d
    ! k- L; T7 R+ bApplication.ScreenUpdating = False
    , F; D5 b: Z2 V2 E1 G
    / s* j7 E- H* F4 _: SMyPath = ActiveWorkbook.Path
    ' o; N( \/ C0 u3 M$ k; k4 ?
    * @8 U+ V  }1 A- O% FMyName = Dir(MyPath & "\" & "*.xls")0 U7 c9 ?8 Y, |" u0 ^% G

    * r7 {5 A5 v2 zAWbName = ActiveWorkbook.Name
    ; h1 s5 A/ S9 O$ X
    , i+ ~- ?) Q% X* a# _0 S3 iNum = 0
    : Y9 b4 X, \# O- U, n. E3 P8 q' ?2 J. l( h  z- D
    Do While MyName <> ""
    ) t) v2 S/ F. ]& c) A" V+ X& S" z1 K. ^
    If MyName <> AWbName Then$ s  B2 m3 B8 O) V4 I8 q& t7 w

    ' U* X! M# @, ^1 dSet Wb = Workbooks.Open(MyPath & "\" & MyName); ~7 f: j0 ~3 b3 I2 W* P
    - u8 b9 |  D8 w
    Num = Num + 1( `+ @- @& C5 {0 p

    4 [4 V) c3 q3 ]4 m8 o" zWith Workbooks(1).ActiveSheet
    ! m* S4 M: a* @$ p: k( b2 z6 o6 q" y6 T$ |
    .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)( q' h3 e4 d/ m, D* W
    6 D' M( j; e& o9 s
    For G = 1 To Sheets.Count
    4 Z; P9 w* `7 Z2 Z+ B1 E; ~7 s! l9 w8 x& T7 B: r8 n
    Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1), L0 O- T% r0 x, c" H3 v
    * d" F6 k# |  i4 J  n8 r: y
    Next$ Z( v7 |7 V& Z: @/ X
    + \: |6 n' ?' l# z
    WbN = WbN & Chr(13) & Wb.Name
    : ?' p2 R% Y& `4 P8 ]) B6 W3 {* Y( J( F) {" X0 _3 U' ^
    Wb.Close False
    + z, i$ m1 {. e* G' F) _0 I4 e+ S  G( ~3 m, \
    End With
    3 R: ]" c# r6 h3 E5 }; G& {+ x
    8 K3 l' V  ^6 R, a7 T: nEnd If
    ) e3 U0 t# k7 L. W7 d/ ^
      w4 |/ @5 V8 \) U- R6 I& r9 XMyName = Dir; ~3 M- M5 C! W& Z% c2 J3 S0 W

    3 h; B( V+ q2 [% jLoop
    ( e3 |6 k5 f; T# w* n  \: }/ N- V
    Range("B1").Select
    : N& ~4 o8 J; S) E7 r( K5 w
    & u4 u. ?' N8 JApplication.ScreenUpdating = True2 C- K& f/ I1 M; P0 b3 c2 U# w
    : ~9 O6 w4 `; D6 x3 @
    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" & Chr(13) & WbN, vbInformation, "提示"
    " j& d& c+ V$ e% Z
    ! h- y" L. y* P$ iEnd Sub
    您需要登录后才可以回帖 登录 | 立即注册

    本版积分规则

    Archiver|手机版|小黑屋|PTShare

    GMT+8, 2025-2-19 07:17

    Powered by Discuz! X3.4 Licensed

    © 2001-2023 Discuz! Team.

    快速回复 返回顶部 返回列表