[已解决]怎样判断文件名是否相同

乐乐2006201506

        怎样判断文件名是否相同？下面第一段代码可以提取指定文件夹工作簿文件名，第二段代码可以提取指定文件夹中文本文件文件名，假如两个文件夹中工作簿和文本文件比较多，怎样用代码匹配相同文件名，然后将文本文件内容导入工作簿中。谢谢！

Sub 提取指定文件夹内的所有文件名() '含所有子文件夹内的文件
    Dim Fso As Object, arrf$(), mf&
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Call GetFiles("C:\Users\YYB\Desktop\导入文本文件 - 副本\", Fso, arrf, mf)
    [A1].Resize(mf) = Application.Transpose(arrf)
    Set Fso = Nothing
End Sub
Private Sub GetFiles(ByVal sPath$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
    Dim Folder As Object
    Dim SubFolder As Object
    Dim File As Object
    Dim En$
    Set Folder = Fso.GetFolder(sPath)
    For Each File In Folder.Files
        En = Fso.GetExtensionName(sPath & "\" & File.Name)
        If En Like "*xls*" Then
            mf = mf + 1
            ReDim Preserve arrf(1 To mf)
            arrf(mf) = Left(File.Name, Len(File.Name) - (Len(File.Name) - InStr(File.Name, ".")) - 1)
        End If
    Next
    For Each SubFolder In Folder.SubFolders
        Call GetFiles(SubFolder.Path, Fso, arrf, mf)
    Next
    Set Folder = Nothing
    Set File = Nothing
End Sub

Sub 提取指定文件夹内的所有文件名1() '含所有子文件夹内的文件
    Dim Fso As Object, arrf1$(), mf1&
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Call GetFiles1("C:\Users\YYB\Desktop\导入文本文件 - 副本\", Fso, arrf1, mf1)
    [B1].Resize(mf1) = Application.Transpose(arrf1)
    Set Fso = Nothing
End Sub
Private Sub GetFiles1(ByVal sPath$, ByRef Fso As Object, ByRef arrf1$(), ByRef mf1&)
    Dim Folder As Object
    Dim SubFolder As Object
    Dim File As Object
    Dim En$
    Set Folder = Fso.GetFolder(sPath)
    For Each File In Folder.Files
        En = Fso.GetExtensionName(sPath & "\" & File.Name)
        If En Like "*txt" Then
            mf1 = mf1 + 1
            ReDim Preserve arrf1(1 To mf1)
            arrf1(mf1) = Left(File.Name, Len(File.Name) - (Len(File.Name) - InStr(File.Name, ".xls")) - 1)
        End If
    Next
    For Each SubFolder In Folder.SubFolders
        Call GetFiles1(SubFolder.Path, Fso, arrf1, mf1)
    Next
    Set Folder = Nothing
    Set File = Nothing
End Sub

下面代码可以将文本文件导入指定工作表中。

Sub 读取文本文件并放入指定工作表遍历()
    Dim Fso As Scripting.filesystemobject
    Dim mt As Scripting.textstream
    Dim myfile$, i&, sht$, b As Boolean, rng$, fm$
    myfile = Application.GetOpenFilename("TXT Files (*.txt), *.txt", 0, "选定文件", , False)
    If myfile = "" Then Exit Sub
    Set Fso = New Scripting.filesystemobject
    Set mt = Fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
    sht = "测试"  '公式插入那个工作表
    With mt
        Do Until .AtEndOfStream
            i = i + 1
            If i Mod 3 = 1 Then
                b = False
                sht = .ReadLine
            End If
            If i Mod 3 = 2 Then
                b = False
                rng = .ReadLine
            End If
            If i Mod 3 = 0 Then
                b = True
                fm = .ReadLine
            End If
            If b = True Then Sheets(sht).Range(rng).Formula = fm
        Loop
        .Close
    End With
    MsgBox "公式还原成功！"
End Sub

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-27 22:14

我这个做的是批量的把所有文件夹中的工作簿公式读取出来并保存在文本文件中，每个工作簿对应一个文本文件，最后可以批量的把这些文件夹中的工作簿对应工作表中的公式从文本文件中读取并进行还原，附件是包含了测试文件，第一次使用的时候必须遵守以下步骤：
1、删除公式文件夹下的所有文本文件（只有当改变了整个文件路径的时候执行）
2、执行过程“读取各工作簿对应工作表中公式并存储”（这时会在公式文件夹中生成N个文本文件）
3、你可以把原来已经读取并保存了的公式删掉用于测试，再执行“遍历所有工作薄并读取文本文件公式并放入对应工作表”这个过程，此时还原所有的公式！

保存公式时由于是把工作簿的路径保存为文档名称，而原因的时候也是依据路径去对于的文本文件，所有两个相对路径一定要对，即如果文件有移动，那么就要去执行步骤一！

整个过程可作为学习参考！

1. Sub 读取各工作簿对应工作表中公式并存储() '含所有子文件夹内的文件，对每个工作簿创建一个独立的文本文档
   
2.     Dim fso As Object, arrf$(), mf&, MyPath$, sht As Worksheet, wb As Workbook, Cell As Range, FormulaCells As Range
   
3.     Dim mt As Scripting.textstream
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set objShell = CreateObject("Shell.Application")
   
6.     Set objFolder = objShell.BrowseForFolder(0, "请选择来源位置", 0, 0)  '注意这里选择的是EXCEL表格所在的位置
   
7.     If Not objFolder Is Nothing Then
   
8.         MyPath = objFolder.self.Path
   
9.     Else
   
10.         MyPath = ""
    
11.         Exit Sub
    
12.     End If
    
13.     Call GetFiles(MyPath, fso, arrf, mf)
    
14.     Application.AskToUpdateLinks = False
    
15.     Application.DisplayAlerts = False
    
16.     If mf > 0 Then
    
17.         For i = 1 To mf
    
18.             Set wb = GetObject(arrf(i))
    
19.             myfile = ThisWorkbook.Path & "\公式" & Replace(Replace(arrf(i), "", "^"), ":", "$") & ".txt"  '为了简便这里把公式存放在当前位置的【公式】文件夹中
    
20.             Set mt = fso.CreateTextFile(Filename:=myfile, overwrite:=True)
    
21.             For Each sht In wb.Sheets
    
22.                 Set FormulaCells = sht.Range("A1").SpecialCells(xlFormulas, 23)
    
23.                 If (FormulaCells Is Nothing) = 0 Then
    
24.                     For Each Cell In FormulaCells
    
25.                         mt.Write sht.Name & vbCrLf
    
26.                         mt.Write Cell.Address(RowAbsolute:=False, ColumnAbsolute:=False) & vbCrLf
    
27.                         mt.Write Cell.Formula & vbCrLf
    
28.                     Next
    
29.                 End If
    
30.                 Set FormulaCells = Nothing
    
31.             Next
    
32.             wb.Close False
    
33.         Next
    
34.     Else
    
35.         Exit Sub
    
36.     End If
    
37.     Application.DisplayAlerts = True
    
38.     Application.AskToUpdateLinks = True
    
39.     Set fso = Nothing
    
40. End Sub
    
41. 
    
42. Sub 遍历所有工作薄并读取文本文件公式并放入对应工作表()
    
43.     Dim fso As Object
    
44.     Dim mt As Scripting.textstream
    
45.     Dim myfile$, i&, sht$, b As Boolean, rng$, fm$, MyPath$, arrf$(), mf&, x&, wb As Workbook
    
46.     Set fso = CreateObject("Scripting.FileSystemObject")
    
47.     Set objShell = CreateObject("Shell.Application")
    
48.     Set objFolder = objShell.BrowseForFolder(0, "请选择目标位置", 0, 0)  '注意这里也是选择EXCEL表格所在的位置
    
49.     If Not objFolder Is Nothing Then
    
50.         MyPath = objFolder.self.Path
    
51.     Else
    
52.         MyPath = ""
    
53.         Exit Sub
    
54.     End If
    
55.     Call GetFiles(MyPath, fso, arrf, mf)
    
56.     Application.AskToUpdateLinks = False
    
57.     Application.DisplayAlerts = False
    
58.     For i = 1 To mf
    
59.         myfile = ThisWorkbook.Path & "\公式" & Replace(Replace(arrf(i), "", "^"), ":", "$") & ".txt"
    
60.         Set fso = New Scripting.filesystemobject
    
61.         Set mt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
    
62.         Set wb = Workbooks.Open(arrf(i))
    
63.         With mt
    
64.             Do Until .AtEndOfStream
    
65.                 x = x + 1
    
66.                 If x Mod 3 = 1 Then
    
67.                     b = False
    
68.                     sht = .ReadLine
    
69.                 End If
    
70.                 If x Mod 3 = 2 Then
    
71.                     b = False
    
72.                     rng = .ReadLine
    
73.                 End If
    
74.                 If x Mod 3 = 0 Then
    
75.                     b = True
    
76.                     fm = .ReadLine
    
77.                 End If
    
78.                 If b = True Then wb.Sheets(sht).Range(rng).Formula = fm
    
79.             Loop
    
80.             .Close
    
81.         End With
    
82.         wb.Close True
    
83.         x = 0
    
84.     Next
    
85.     MsgBox "公式还原成功！"
    
86.     Application.AskToUpdateLinks = True
    
87.     Application.DisplayAlerts = True
    
88. End Sub
    
89. Private Sub GetFiles(ByVal sPath$, ByRef fso As Object, ByRef arrf$(), ByRef mf&) '遍历文件
    
90.     Dim Folder As Object
    
91.     Dim SubFolder As Object
    
92.     Dim File As Object
    
93.     Dim En$
    
94.     Set Folder = fso.GetFolder(sPath)
    
95.     For Each File In Folder.Files
    
96.         En = fso.GetExtensionName(sPath & "" & File.Name)
    
97.         If En Like "*xls*" Then
    
98.             mf = mf + 1
    
99.             ReDim Preserve arrf(1 To mf)
    
100.             arrf(mf) = sPath & "" & File.Name
     
101.         End If
     
102.     Next
     
103.     For Each SubFolder In Folder.SubFolders
     
104.         Call GetFiles(SubFolder.Path, fso, arrf, mf)
     
105.     Next
     
106.     Set Folder = Nothing
     
107.     Set File = Nothing
     
108. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

我这个做的是批量的把所有文件夹中的工作簿公式读取出来并保存在文本文件中，每个工作簿对应一个文本文件，最后可以批量的把这些文件夹中的工作簿对应工作表中的公式从文本文件中读取并进行还原，附件是包含了测试文件，第一次使用的时候必须遵守以下步骤：
1、删除公式文件夹下的所有文本文件（只有当改变了整个文件路径的时候执行）
2、执行过程“读取各工作簿对应工作表中公式并存储”（这时会在公式文件夹中生成N个文本文件）
3、你可以把原来已经读取并保存了的公式删掉用于测试，再执行“遍历所有工作薄并读取文本文件公式并放入对应工作表”这个过程，此时还原所有的公式！

保存公式时由于是把工作簿的路径保存为文档名称，而原因的时候也是依据路径去对于的文本文件，所有两个相对路径一定要对，即如果文件有移动，那么就要去执行步骤一！

整个过程可作为学习参考！

1. Sub 读取各工作簿对应工作表中公式并存储() '含所有子文件夹内的文件，对每个工作簿创建一个独立的文本文档
   
2.     Dim fso As Object, arrf$(), mf&, MyPath$, sht As Worksheet, wb As Workbook, Cell As Range, FormulaCells As Range
   
3.     Dim mt As Scripting.textstream
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set objShell = CreateObject("Shell.Application")
   
6.     Set objFolder = objShell.BrowseForFolder(0, "请选择来源位置", 0, 0)  '注意这里选择的是EXCEL表格所在的位置
   
7.     If Not objFolder Is Nothing Then
   
8.         MyPath = objFolder.self.Path
   
9.     Else
   
10.         MyPath = ""
    
11.         Exit Sub
    
12.     End If
    
13.     Call GetFiles(MyPath, fso, arrf, mf)
    
14.     Application.AskToUpdateLinks = False
    
15.     Application.DisplayAlerts = False
    
16.     If mf > 0 Then
    
17.         For i = 1 To mf
    
18.             Set wb = GetObject(arrf(i))
    
19.             myfile = ThisWorkbook.Path & "\公式" & Replace(Replace(arrf(i), "", "^"), ":", "$") & ".txt"  '为了简便这里把公式存放在当前位置的【公式】文件夹中
    
20.             Set mt = fso.CreateTextFile(Filename:=myfile, overwrite:=True)
    
21.             For Each sht In wb.Sheets
    
22.                 Set FormulaCells = sht.Range("A1").SpecialCells(xlFormulas, 23)
    
23.                 If (FormulaCells Is Nothing) = 0 Then
    
24.                     For Each Cell In FormulaCells
    
25.                         mt.Write sht.Name & vbCrLf
    
26.                         mt.Write Cell.Address(RowAbsolute:=False, ColumnAbsolute:=False) & vbCrLf
    
27.                         mt.Write Cell.Formula & vbCrLf
    
28.                     Next
    
29.                 End If
    
30.                 Set FormulaCells = Nothing
    
31.             Next
    
32.             wb.Close False
    
33.         Next
    
34.     Else
    
35.         Exit Sub
    
36.     End If
    
37.     Application.DisplayAlerts = True
    
38.     Application.AskToUpdateLinks = True
    
39.     Set fso = Nothing
    
40. End Sub
    
41. 
    
42. Sub 遍历所有工作薄并读取文本文件公式并放入对应工作表()
    
43.     Dim fso As Object
    
44.     Dim mt As Scripting.textstream
    
45.     Dim myfile$, i&, sht$, b As Boolean, rng$, fm$, MyPath$, arrf$(), mf&, x&, wb As Workbook
    
46.     Set fso = CreateObject("Scripting.FileSystemObject")
    
47.     Set objShell = CreateObject("Shell.Application")
    
48.     Set objFolder = objShell.BrowseForFolder(0, "请选择目标位置", 0, 0)  '注意这里也是选择EXCEL表格所在的位置
    
49.     If Not objFolder Is Nothing Then
    
50.         MyPath = objFolder.self.Path
    
51.     Else
    
52.         MyPath = ""
    
53.         Exit Sub
    
54.     End If
    
55.     Call GetFiles(MyPath, fso, arrf, mf)
    
56.     Application.AskToUpdateLinks = False
    
57.     Application.DisplayAlerts = False
    
58.     For i = 1 To mf
    
59.         myfile = ThisWorkbook.Path & "\公式" & Replace(Replace(arrf(i), "", "^"), ":", "$") & ".txt"
    
60.         Set fso = New Scripting.filesystemobject
    
61.         Set mt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
    
62.         Set wb = Workbooks.Open(arrf(i))
    
63.         With mt
    
64.             Do Until .AtEndOfStream
    
65.                 x = x + 1
    
66.                 If x Mod 3 = 1 Then
    
67.                     b = False
    
68.                     sht = .ReadLine
    
69.                 End If
    
70.                 If x Mod 3 = 2 Then
    
71.                     b = False
    
72.                     rng = .ReadLine
    
73.                 End If
    
74.                 If x Mod 3 = 0 Then
    
75.                     b = True
    
76.                     fm = .ReadLine
    
77.                 End If
    
78.                 If b = True Then wb.Sheets(sht).Range(rng).Formula = fm
    
79.             Loop
    
80.             .Close
    
81.         End With
    
82.         wb.Close True
    
83.         x = 0
    
84.     Next
    
85.     MsgBox "公式还原成功！"
    
86.     Application.AskToUpdateLinks = True
    
87.     Application.DisplayAlerts = True
    
88. End Sub
    
89. Private Sub GetFiles(ByVal sPath$, ByRef fso As Object, ByRef arrf$(), ByRef mf&) '遍历文件
    
90.     Dim Folder As Object
    
91.     Dim SubFolder As Object
    
92.     Dim File As Object
    
93.     Dim En$
    
94.     Set Folder = fso.GetFolder(sPath)
    
95.     For Each File In Folder.Files
    
96.         En = fso.GetExtensionName(sPath & "" & File.Name)
    
97.         If En Like "*xls*" Then
    
98.             mf = mf + 1
    
99.             ReDim Preserve arrf(1 To mf)
    
100.             arrf(mf) = sPath & "" & File.Name
     
101.         End If
     
102.     Next
     
103.     For Each SubFolder In Folder.SubFolders
     
104.         Call GetFiles(SubFolder.Path, fso, arrf, mf)
     
105.     Next
     
106.     Set Folder = Nothing
     
107.     Set File = Nothing
     
108. End Sub

复制代码

乐乐2006201506

老司机带带我 发表于 2016-6-27 22:14
我这个做的是批量的把所有文件夹中的工作簿公式读取出来并保存在文本文件中，每个工作簿对应一个文本文件， ...

        1.您这次写的代码，完全可以实现要求，但有一点，和下面这个公式一样的公式，会出现错误值，因为您的公式在写入公式时在原来引用路径前加了路径“E:\Excel\Excel精英群\写入删除代码\写入代码多层子文件夹\花名册测试文件\”，能不能麻烦您解决这个问题。谢谢！
=VLOOKUP($B3,'E:\Excel\Excel精英群\写入删除代码\写入代码多层子文件夹\花名册测试文件\F\工资资料\2015年工资资料\[二中2015年10月在职.xls]201510'!$C$2:$K$239,5,0)

        2.我在工作簿这个公式“=VLOOKUP($B3,'E:\Excel\Excel精英群\写入删除代码\写入代码多层子文件夹\花名册测试文件\F\工资资料\2015年工资资料\[二中2015年10月在职.xls]201510'!$C$2:$K$239,5,0)”所在单元格删除掉“E:\Excel\Excel精英群\写入删除代码\写入代码多层子文件夹\花名册测试文件\”路径，或者将文本文件中E:\Excel\Excel精英群\写入删除代码\写入代码多层子文件夹\花名册测试文件\这个路径删除导入工作簿后，都会出现下面情况。公式中会自动添加“C:\Users\YYB\Desktop\”这个路径，导致引用不正确。不知道是怎么回事。请赐教，谢谢！
=VLOOKUP($B3,'C:\Users\YYB\Desktop\F\工资资料\2015年工资资料\[二中2015年10月在职.xls]201510'!$C$2:$K$239,5,0)。

老司机带带我

乐乐2006201506 发表于 2016-6-28 09:07
1.您这次写的代码，完全可以实现要求，但有一点，和下面这个公式一样的公式，会出现错误值，因为 ...

这个代码只做参考，实际使用的时候本身就不提倡这种做法！

乐乐2006201506

老司机带带我 发表于 2016-6-28 09:41
这个代码只做参考，实际使用的时候本身就不提倡这种做法！

        麻烦您解决一下这个问题，谢谢！
        您当然能够解决这个小问题的。