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

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

感谢论坛大佬

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

    [LV.2]偶尔看看I

    发表于 2020-7-6 10:05:41 | 显示全部楼层 |阅读模式
    Sub 合并当前目录下所有工作簿的全部工作表()
    ' H' D* Y- O5 n+ v9 A. _0 a% U* G3 z+ o. y: a# H( Q, w
    Dim MyPath, MyName, AWbName# P/ x' V: ^4 q! u
    3 |8 p* R$ W/ C9 N* ]
    Dim Wb As Workbook, WbN As String+ `* N4 ?0 {  C9 f5 ?8 e
    6 r% f$ v9 F+ D; g0 M4 ]
    Dim G As Long5 u7 G, ]4 ^4 y* t! O6 N9 F
    , w. Z! q" c4 \$ g6 |
    Dim Num As Long
    3 ^( C8 f* C. \7 L4 L0 M( l$ o/ G0 o/ H. n" |6 e; [; G
    Dim BOX As String
    - k7 c1 G+ T, N. y) A
    0 {7 T; B9 Z# PApplication.ScreenUpdating = False) j; a8 B- W$ J4 `( L
    & `! i5 G2 A& z% d) `
    MyPath = ActiveWorkbook.Path
    6 E7 q) C& i2 l1 p. m$ o( h7 j
    3 F$ T: M# \. tMyName = Dir(MyPath & "\" & "*.xls"), _3 d- R  u+ G; s5 Q4 K
    9 X2 i+ k& q) _% k6 H$ F& x
    AWbName = ActiveWorkbook.Name
    . i7 S. D+ Q3 E: F* G7 V  _6 g1 w$ _/ w' h" o/ U  L
    Num = 02 s! ~3 A5 Z% T" x/ c$ y
    , r( b0 K- f5 k$ U+ E
    Do While MyName <> ""& C8 v( ^+ H' p1 x+ v) K7 X3 I

    1 I( _* k0 c, f" H( e+ V2 yIf MyName <> AWbName Then' k  V/ A" @3 }8 b! ^* S* {" Y
    3 g* ?) f( g2 _2 p6 X/ e8 f3 ^7 Q  J
    Set Wb = Workbooks.Open(MyPath & "\" & MyName)  T& L8 j  \+ F! x$ q/ ~' T+ c( _

    # ]+ Q6 R6 {6 V: oNum = Num + 1  I* D# i& @+ ?9 {

    " `8 A! u. `: mWith Workbooks(1).ActiveSheet
    7 c# z' Z( _  T. H0 k$ ?. s
    7 Q+ M, r/ w4 }) ?0 l.Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
    . h6 |; u5 W$ V, i' |* L) W  s8 m. y8 i" v6 o
    For G = 1 To Sheets.Count- l$ A( y9 B1 r& e* c& W
    " p( o$ o7 ^* i+ j  V" X! e# k
    Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)2 y9 o. e8 N6 c

    9 C' e& Y6 I/ INext
      y9 `3 M' }' k
    + i) ^- |# a8 C" X) ?WbN = WbN & Chr(13) & Wb.Name2 C; U0 o% g5 Q6 c9 G( D5 A

    3 n! k4 G0 q( f2 P: ~* aWb.Close False: H' z: ]" f  L2 H) t

    " w: g( C- \/ uEnd With
    5 p1 J, ]% o7 c: |! t! V
    : M" X( p( V8 B( C4 ]  C( y9 pEnd If- W& v+ o( u+ B( @6 j. r( ]: {

    7 X  h6 d) E1 U! U$ D% {: jMyName = Dir9 e$ M% }7 i3 Y1 {

    7 [. t9 P0 c5 k$ M( [Loop
    % z- K* o3 d, @, j/ h( R7 Z' x6 s  u" D2 M* C0 X  Q2 e
    Range("B1").Select
    8 i9 K3 @1 M7 D8 U  ~# }$ \
    5 G/ K. L: a0 K# vApplication.ScreenUpdating = True
    # ~) u/ H5 ^/ Y* Y. ?
    ! i. Z* k* S+ mMsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" & Chr(13) & WbN, vbInformation, "提示"
    + a+ `" M" `% v$ U/ p) \* b# O, O" c0 H. ~& n: i6 }, D6 _
    End Sub
    您需要登录后才可以回帖 登录 | 立即注册

    本版积分规则

    Archiver|手机版|小黑屋|PTShare

    GMT+8, 2024-11-23 21:47

    Powered by Discuz! X3.4 Licensed

    © 2001-2023 Discuz! Team.

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