见证成长历程---我的答疑解难代码汇总

wherecoor

lsc900707 发表于 2017-3-23 00:34
帮忙修改一下代码，改成可以合并子文件夹里的所有工作簿
http://club.excelhome.net/thread-1335341-1-1.h ...

老师，就是合并指定文件夹里01-05类似的这种文件

lsc900707

wherecoor 发表于 2017-4-10 10:06
老师，就是合并指定文件夹里01-05类似的这种文件

请上传附件，我只能晚上解压附件再回复你。

wherecoor

lsc900707 发表于 2017-4-10 10:12
请上传附件，我只能晚上解压附件再回复你。

老师，我晚上回去了发给你附件

wherecoor

老师我的要求是要我x1+x2表中的www-x1和www-x2内容能够被识别以x1和x2为查询目标调出x1表和x2表的数据到一个表中做汇总

wherecoor

wherecoor 发表于 2017-4-10 19:34
老师我的要求是要我x1+x2表中的www-x1和www-x2内容能够被识别以x1和x2为查询目标调出x1表和x2表的数据到一 ...

我不会做这中类似地址引用的，谢谢老师

lsc900707

wherecoor 发表于 2017-4-10 19:35
我不会做这中类似地址引用的，谢谢老师

没理解你的意思。参考代码：
Sub lsc()
   t = Timer
   myPath = ThisWorkbook.Path & "\"
   MyName = Dir(myPath & "*.xls*")
   Application.ScreenUpdating = False
   ReDim brr(1 To 3000, 1 To 5)
   Do While MyName <> ""
       If MyName <> ThisWorkbook.Name Then
           n = n + 1
           Set sh = GetObject(myPath & MyName).Sheets("Sheet1")
           Arr = sh.[a1].CurrentRegion
           Workbooks(MyName).Close False
           For i = 2 To UBound(Arr)
                m = m + 1
                For j = 1 To 5
                    brr(m, j) = Arr(i, j)
                Next
            Next
        End If
    MyName = Dir
Loop
Set sh = Nothing
With Sheet1
     .Rows("1:3000").ClearContents
     .[a1].Resize(1, UBound(Arr, 2)).Value = Arr
     .[a2].Resize(m, UBound(brr, 2)).Value = brr
End With
Application.ScreenUpdating = True
MsgBox "汇总完成！汇总了：" & n & "个工作表；共有：" & m & "行数据。" & vbCr & "用时：" & Format(Timer - t, "0.00") & "秒", vbInformation
End Sub

wherecoor

lsc900707 发表于 2017-4-11 00:54
没理解你的意思。参考代码：
Sub lsc()
   t = Timer

就是识别“www-x1“”这个内容的“x1“，之后对应我的x1这个表，通过这种方式把x1、x2表倒到x1+x2表里面，识别几个字符合并与字符名字相同的表

lsc900707

wherecoor 发表于 2017-4-11 09:07
就是识别“www-x1“”这个内容的“x1“，之后对应我的x1这个表，通过这种方式把x1、x2表倒到x1+x2表里面 ...

汇总的内容从B列开始，代码识别A列的文件名?

wherecoor

lsc900707 发表于 2017-4-11 09:14
汇总的内容从B列开始，代码识别A列的文件名?

汇总内容从f列开始，代码识别a列的文件名

lsc900707

wherecoor 发表于 2017-4-11 09:20
汇总内容从f列开始，代码识别a列的文件名

用这个吧，工作簿名不相同的话注意修改标红处：
Sub lsc()
    Set sh = ActiveSheet
    arr = sh.[a1].CurrentRegion
    mypath = ThisWorkbook.Path
    myname = ThisWorkbook.Name
    Dname = Dir(mypath & "\*.xls*")
    Application.ScreenUpdating = False
    Do While Dname <> ""
        For i = 2 To UBound(arr)
           If Split(Dname, ".")(0) = Mid(arr(i, 1), 5, 2) And Dname <> myname Then
               With GetObject(mypath & "\" & Dname)
                   .Sheets(1).UsedRange.Offset(1, 0).Copy sh.Cells(Rows.Count, 6).End(xlUp).Offset(1)
                   .Close False
               End With
           End If
        Next
        Dname = Dir
   Loop
   Application.ScreenUpdating = True
   MsgBox "OK!"
   End Sub