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

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

感谢论坛大佬

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

    [LV.2]偶尔看看I

    发表于 2020-7-6 10:05:41 | 显示全部楼层 |阅读模式
    Sub 合并当前目录下所有工作簿的全部工作表()) g7 ]) D% V3 k6 o1 y8 Q# r$ B, y

    : E4 |! \, m6 w! q( n6 BDim MyPath, MyName, AWbName
    5 b8 {9 M, \2 G2 ^- M8 G. g2 k6 k" ~6 F. `) Q% f1 I; ^: k
    Dim Wb As Workbook, WbN As String
    ) u: v6 ~! V4 E6 m) L% H, v( G/ R) Q) @$ Y5 U+ Y$ n' N8 a4 b2 E
    Dim G As Long
    # `+ @8 U5 ~* j
    + O4 X, r; Y. m( p* k* zDim Num As Long; J+ o$ r! n' N6 V! u/ @; W: t

    : v6 i1 f- N7 q" vDim BOX As String1 p! v2 o1 n! g; y  c7 ~" s3 L
    ( b( C- j( S1 S# X: B
    Application.ScreenUpdating = False; ^9 G; H- o& i

    8 j) _) S; b$ X' W2 RMyPath = ActiveWorkbook.Path, h/ l8 o! V. r
    & C; r% \+ Y. {' E- H, E
    MyName = Dir(MyPath & "\" & "*.xls")/ Y: B( {6 u7 Y8 n2 M

    9 h( e2 V: o, p) {AWbName = ActiveWorkbook.Name* a' ?# ^+ c- d, t: n# Y
    % v* P! k& @- {3 V
    Num = 0
      Y6 c8 o, ~+ j, u8 I2 w* B! T, x
    9 S1 J# @" |) l# P, ~" FDo While MyName <> ""! g! I5 l0 w+ b5 ^( o
    " r, @& U* O4 `4 j0 W3 L9 ~8 Q
    If MyName <> AWbName Then' D! Q% c7 b  n/ Y7 _: `2 F9 Q

    7 R& {* S9 M+ `( i5 kSet Wb = Workbooks.Open(MyPath & "\" & MyName)6 x5 q" n' q7 J1 f% O
    ( a3 ]8 q' E# O, G6 M% X) h
    Num = Num + 1" M5 T' m# l* R

    . p3 Z' W  e4 T0 BWith Workbooks(1).ActiveSheet0 `  {" m2 O, e! u8 L8 y
    7 g' F- E& X1 I4 p0 G6 Q$ n
    .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
    8 h5 `& b* Z! J3 H1 ~: ]" `3 N
    1 Y# L2 I/ }5 |' {For G = 1 To Sheets.Count' U$ z9 e* v" Y4 B) ?; E% s1 A' m
    3 z# J2 o& \7 X' e! `" h$ d$ ~
    Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
    , `( t! K1 Q% d! ]; D3 [$ _3 v7 N/ ~3 \& |
    Next
    ( q% q! _! P% g  R; z7 i( I. o5 z5 X; \
    WbN = WbN & Chr(13) & Wb.Name! t8 w- K6 ~" l: ]8 S

    3 y1 @. m  l* M' ^% ~1 mWb.Close False
    4 B* F/ V7 `- t+ R- a5 @/ o" e. l( ?( {5 V( f  R
    End With5 [% V0 n: N" `2 B. ?  C
    $ i! B: l! L: R# [- j0 |
    End If
    . _* I- r) K& K0 G
    8 p- ~0 W9 M0 }. H. C5 `MyName = Dir( V2 C+ W# @8 e0 S

    9 h2 B" B, `, D! {" ILoop
    / l7 V# x7 `9 E7 L: ~, P) I2 W! U8 X+ H9 q; ~, n2 P9 j$ Z
    Range("B1").Select
    , U8 F1 ?9 a4 e1 ]3 I5 o& }
    , Z+ J8 R+ S: a9 c& t# d8 P/ n, LApplication.ScreenUpdating = True  Q6 I8 w; v( E2 Q

    / {. M- u" V/ V/ U! }( kMsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" & Chr(13) & WbN, vbInformation, "提示"8 p; n8 L2 N$ I) Q2 v1 R
    0 _; E, d& M; P: o" C. u
    End Sub
    您需要登录后才可以回帖 登录 | 立即注册

    本版积分规则

    Archiver|手机版|小黑屋|PTShare

    GMT+8, 2025-2-21 03:13

    Powered by Discuz! X3.4 Licensed

    © 2001-2023 Discuz! Team.

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