排除当前代码所在工作簿---为什么这句不起作用

鄂龙蒙

请教：下面的代码中，排除当前代码所在工作簿---为什么这句不起作用？谢谢！

Sub 汇总当前文件夹及子文件夹下所有工作薄的内容()
    ActiveSheet.UsedRange.ClearContents
    Application.ScreenUpdating = False
    Cells(1, 1) = "文件夹名"
    Cells(1, 2) = "薄名"
    Cells(1, 3) = "表名"
    Getfd (ThisWorkbook.Path)
    Application.ScreenUpdating = True
End Sub

Sub Getfd(ByVal pth)
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.GetFolder(pth)
'    On Error Resume Next
    For Each f In ff.Files
        If InStr(Split(f.Name, ".")(1), "xls") > 0 Then
'            If f.Name <> ThisWorkbook.Name Then        '排除当前代码所在工作簿---为什么这句不起作用
            If f.Name <> ThisWorkbook.Name And f.Name <> "~$数据汇总.xlsm" Then   '加一个条件可行--为什么要加后一个条件？
                Set wb = Workbooks.Open(f)
                Sheet1.Cells(Rows.Count, 1).End(3).Offset(1) = ff.Name
                Sheet1.Cells(Rows.Count, 2).End(3).Offset(1) = f.Name
                Sheet1.Cells(Rows.Count, 3).End(3).Offset(1) = wb.Sheets(1).Name
                wb.Close False
            End If
        End If
    Next f
    For Each fd In ff.Subfolders
        Getfd (fd)
    Next fd
End Sub

多层文件夹下文件.rar (25.93 KB, 下载次数: 6)

2018-10-15 08:55 上传

点击文件名下载附件

liulang0808

If f.Name <> ThisWorkbook.Name Then        '排除当前代码所在工作簿---为什么这句不起作用
这句代码有时会导致错误提醒的
当ThisWorkbook.Name扩展名 未xls使用没有问题，当时xlsm的时候，就要报错了。

lss001

应改为→
If Right(f.Name, Len(f.Name) - 2)<> Right(ThisWorkbook.FullName, Len(f.Name) - 2) Then  

鄂龙蒙

lss001 发表于 2018-10-15 10:08
应改为→
If f.Name  ThisWorkbook.FullName Then

改了测试还是不行，
If f.Name <> ThisWorkbook.Name And f.Name <> "~$数据汇总.xlsm" Then  
'要加后一个条件才行，真的不知为什么？

鄂龙蒙

lss001 发表于 2018-10-15 10:08
应改为→
If f.Name  ThisWorkbook.FullName Then

运行代码出现这样的提示

一把小刀闯天下

鄂龙蒙 发表于 2018-10-15 10:22
运行代码出现这样的提示

'包含子目录，输出目录全名，自己修改

Option Explicit

Sub 汇总当前文件夹及子文件夹下所有工作薄的内容()
  Dim filename(), n, fso, mark, sht, i, j, m, s
  Set fso = CreateObject("scripting.filesystemobject")
  mark = Split(".xls .xlsx .xlsm")
  Call getfilename(fso, filename, n, ThisWorkbook.Path, mark)
  If n = 0 Then MsgBox "!": Exit Sub
  ReDim arr(1 To n, 1 To 3) As String
  For i = 1 To UBound(filename, 1)
    If ThisWorkbook.FullName <> filename(i) Then
      m = m + 1: s = vbNullString
      For j = Len(filename(i)) To 1 Step -1
        If Mid(filename(i), j, 1) = "\" Then
          arr(m, 1) = Left(filename(i), j - 1)
          arr(m, 2) = Mid(filename(i), j + 1)
          Exit For
        End If
      Next
      With GetObject(filename(i))
        For Each sht In .Sheets
          s = s & "|" & sht.Name
        Next
       .Close
      End With
      arr(m, 3) = Mid(s, 2)
    End If
  Next
  With [a1]
    .Resize(Rows.Count, UBound(arr, 2)).ClearContents
    .Resize(, 3) = Split("文件夹名 薄名 表名")
    .Offset(1).Resize(m, UBound(arr, 2)) = arr
  End With
End Sub

Function getfilename(fso, filename, n, pth, mark)
  Dim spth, t, i
  If Right(pth, 1) <> "\" Then pth = pth & "\"
    Set spth = fso.getfolder(pth)
    For Each t In spth.Files
      For i = 0 To UBound(mark)
        If LCase(Right(t, Len(mark(i)))) = LCase(mark(i)) And Left(t.Name, 1) <> "~" Then
          n = n + 1: ReDim Preserve filename(1 To n)
          filename(n) = spth & "\" & t.Name
        End If
      Next
    Next
    For Each t In spth.subfolders
      Call getfilename(fso, filename, n, t, mark)
    Next
End Function

lsc900707

鄂龙蒙 发表于 2018-10-15 10:22
运行代码出现这样的提示

你的汇总工作簿是07以下版本就没问题
Sub Getfd(ByVal pth)
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.GetFolder(pth)
    For Each f In ff.Files
           If f.Name <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(f)
                Sheet1.Cells(Rows.Count, 1).End(3).Offset(1) = ff.Name
                Sheet1.Cells(Rows.Count, 2).End(3).Offset(1) = f.Name
                Sheet1.Cells(Rows.Count, 3).End(3).Offset(1) = wb.Sheets(1).Name
                wb.Close False
            End If
    Next f
    For Each fd In ff.Subfolders
        Getfd (fd)
    Next fd

lss001

文件格式类型问题？
应改为→
If Right(f.Name, Len(f.Name) - 2) <> Right(ThisWorkbook.FullName, Len(f.Name) - 2) Then