开发起因：

最近领导让我用excel的自带的VBA语言开发一个工具。

开发要求：

实现从一个目录excel文件中读取到文件名，然后通过这个文件名去指定路径搜索对应文件，搜索到对应文件之后，打开并读取该文件中的内容，然后将读取到的内容保存成指定.txt文件，并且指定存储路径。

步骤分解一下：

1.从目录excel中读取到文件名
2.通过这个文件名去指定路径搜索对应文件
3.如果这个文件存在，则打开并读取对应内容
4.将读取到的内容保存成.txt文件
5.如果有保存路径则跳过，没有则创建对应文件路径

实现步骤

1.画UI界面

画图比较难看，大家将就着看吧，哈哈。

2.读取目录文件内容

由于目录文件内容比较多，所以将读取到的数据存储在Collection对象中。

  ''创建Collection对象
    Dim arr As New Collection
    ''从TXT做成.xlsm工具中取得【目录文件路径】
    path1 = Range("E7").Value
    If path1 = "" Then
        MsgBox "请输入【目录文件路径】。“
    Else
    	''打开指定路径下目录文件
        Set xlBook = Excel.Application.Workbooks.Open(path1)
        ''读取该目录文件第二个sheet的内容
        Set sheet = xlBook.Worksheets(2)
        ''获取该sheet最大的印刷行
        maxRow = sheet.Cells(sheet.Rows.Count, 1).End(xlUp).Row
        ''从第四行开始读取对应内容
        For i = 4 To maxRow
        ''如果数据不为空，将该数据写入到Collection对象中
                If sheet.Cells(i, 1) <> "" Then
                   arr.Add (sheet.Cells(i, 1) & "_" & sheet.Cells(i, 2))
                Else
                   MsgBox m & " 行目ID不存在。"
                   Exit Sub
                End If
        Next i
        xlBook.Close
    End If

3.将读取到的Collection对象依次从【读取对象路径】下查找对应文件

''从TXT做成.xlsm工具中取得【对象路径】
path2 = Range("E10").Value
    If path2 = "" Then
       MsgBox "请输入对象路径"
   Else
For Each item In arr
		''指定保存文件路径和文件名
		saveFile = "C:\save\index.txt"
		''从Collection读取到的项目和path2路径拼接，得到完整路径
		path3 = path2 & "\" & item & ".xlsx"
		''打开保存文件
		Open saveFile For Output As #1
		''判断该路径是否存在
		If Dir(path3) <> Empty Then	
               Set xlBook2 = Excel.Application.Workbooks.Open(path3)
               Set ws = xlBook2.Worksheets(1)
               ''获取该sheet最大的印刷行和印刷列
               maxCol2 = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column
               maxRow2 = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
               ''将对象数据写入txt文件
               Print #1, " val " & ws.Cells(j, n) & " = " & ws.Range("C" & j); 
		End If
	Next
Close #1
End If

创建保存路径

Public Function MakeDir(destpath As String)
   On Error Resume Next
   Dim curpath As String
   Dim i As Integer
   Dim path As Variant
   Dim pathstr() As String
   pathstr() = Split(destpath, "\")
   i = 0
   ''进行判断，在保存路径不存在的场合下，创建路径
   For Each path In pathstr()
       i = i + 1
       If i = 1 Then
           curpath = path
       Else
           curpath = curpath & "\" & path
           MkDir curpath
       End If
   Next
End Function

实施如下（由于特殊原因，路径不得不打码）
执行后效果

完整代码如下：

Sub create_code()

  ''变数定义
  Dim xlBook As Excel.Workbook, xlBook2 As Excel.Workbook
  Dim maxRow As Long, maxRow2 As Long, maxCol2 As Long
  Dim m As Long, n As Long
  Dim path1 As String, path2 As String, path3 As String
  Dim saveFile As String
  Dim sheet As Excel.Worksheet
  Dim dataFlag As Boolean
  
  ''创建Collection对象
  Dim arr As New Collection
  '’保存路径创建
  MakeDir ("C:\save")
  
  path1 = Range("E7").Value
  If path1 = "" Then
      MsgBox "请输入【目录文件路径】。"
  Else
      Set xlBook = Excel.Application.Workbooks.Open(path1)
      Set sheet = xlBook.Worksheets(2)
      maxRow = sheet.Cells(sheet.Rows.Count, 1).End(xlUp).Row
      For i = 4 To maxRow
          If sheet.Cells(i, 7) = "〇" Then
              If sheet.Cells(i, 1) <> "" Then
                 arr.Add (sheet.Cells(i, 1) & "_" & sheet.Cells(i, 2))
              Else
                 MsgBox m & " 行目ID不存在。"
                 Close #1
                 Exit Sub
              End If
          End If
      Next i
      xlBook.Close
  End If
  
  saveFile = "C:\save\index.txt"
  saveLog = "C:\save\code_define.log"

  path2 = Range("E10").Value
  If path2 = "" Then
      MsgBox "请输入对象路径"
  Else
      dataFlag = False
      Open saveLog For Output As #2
      Open saveFile For Output As #1
      Print #2, Now() & "------>" & "Start Create"
      For Each item In arr
          m = 0
          n = 0
          path3 = path2 & "\" & item & ".xlsx"
          If Dir(path3) <> Empty Then
              Set xlBook2 = Excel.Application.Workbooks.Open(path3)
              Set ws = xlBook2.Worksheets(1)
              maxCol2 = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column
              maxRow2 = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
              For i = 5 To maxCol2
                  If ws.Cells(3, i) = "表示识别符" Then
                      m = i
                  End If
                  If ws.Cells(3, i) = "数据定数名" Then
                      n = i
                  End If
              Next i
  
              If n = 0 Then
                  Print #2, Now() & "------>" & item + ".xlsx  数据定数名不存在。"
              Else
  
  				Print #1, " val " & ws.Cells(j, n) & " = " & ws.Range("C" & j); 
    
                  Print #2, Now() & "------>" & item + ".xlsx  做成成功。"
              End If
              Workbooks(item & ".xlsx").Close savechanges:=False
          End If
      Next item
       Print #2, Now() & "------>" & "End Create"
      Close #1
      Close #2
  End If
End Sub

''创建路径
Public Function MakeDir(destpath As String)
  On Error Resume Next
  Dim curpath As String
  Dim i As Integer
  Dim path As Variant
  Dim pathstr() As String
  pathstr() = Split(destpath, "\")
  i = 0
  For Each path In pathstr()
      i = i + 1
      If i = 1 Then
          curpath = path
      Else
          curpath = curpath & "\" & path
          MkDir curpath
      End If
  Next
End Function

''清空路径
Sub code_clear()
  Range("E7:L7").ClearContents
  Range("E10:L10").ClearContents
End Sub
  ```