VBA-。查找打印错误的值
我有两段代码，基本上做相同的事情，但有两个不同的列。代码找到标题“切割工具”和“支架”（在多个文件中循环），并将这些列中的信息打印到一个工作表masterfile中 我使用了一种效率较低的方法，将变量设置为一个范围，然后切换到.Find方法。它适用于刀具，但不适用于刀架，我不确定为什么它会不同，因为两者几乎完全相同 切割工具可以正常工作，但HOLDER现在只打印单词HOLDER，而不打印当前的HOLDER。此外，它还包括将空白单元格打印到我的主文件中，但现在它不会这样做。我不确定哪里出了错 以下是我正在处理的特定代码领域：VBA-。查找打印错误的值,vba,excel,Vba,Excel,我有两段代码，基本上做相同的事情，但有两个不同的列。代码找到标题“切割工具”和“支架”（在多个文件中循环），并将这些列中的信息打印到一个工作表masterfile中 我使用了一种效率较低的方法，将变量设置为一个范围，然后切换到.Find方法。它适用于刀具，但不适用于刀架，我不确定为什么它会不同，因为两者几乎完全相同 切割工具可以正常工作，但HOLDER现在只打印单词HOLDER，而不打印当前的HOLDER。此外，它还包括将空白单元格打印到我的主文件中，但现在它不会这样做。我不确定哪里出了错 以下
'(3)
'find CUTTING TOOL on the source sheet'
If Not Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
' Set n = ws.Cells(Rows.count, 1).End(xlUp)
' Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
' If Not hc Is Nothing Then
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
End If
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "3"
End If
'(4)
'find HOLDER on the source sheet
Set ws = WB.ActiveSheet
If Not Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc3 = Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues)
'Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
'If Not hc3 Is Nothing Then
Set dict = GetValues(hc3.Offset(1, 0))
'If InStr(ROW_HEADER, "HOLDER") <> "" Then
If dict.count > 0 Then
'add the values to the master list, column 2
Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "2none"
End If
Else
StartSht.Cells(GetLastRowInColumn(StartSht, "C"), hc1.Column) = "NO HOLDERS PRESENT!" ' change hc2 to hc1
'StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "NO 'HOLDERS' PRESENT!" ' change hc2 to hc1
End If
Option Explicit
Sub LoopThroughDirectory()
Const ROW_HEADER As Long = 10
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim dict As Object
Dim MyFolder As String
Dim f As String
Dim StartSht As Worksheet, ws As Worksheet
Dim WB As Workbook
Dim i As Integer
Dim LastRow As Integer, erow As Integer
Dim Height As Integer
Dim FinalRow As Long
Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, d As Range
Dim TDS As Range
Dim n As Range
Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
'turn screen updating off - makes program faster
Application.ScreenUpdating = False
'location of the folder in which the desired TDS files are
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
'find the headers on the sheet
Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")
Set hc4 = HeaderCell(StartSht.Range("A1"), "TOOLING DATA SHEET (TDS):")
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 2
'loop through directory file and print names
'(1)
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'(2)
'Open folder and file name, do not update links
Set WB = Workbooks.Open(fileName:=MyFolder & objFile.Name, UpdateLinks:=0)
Set ws = WB.ActiveSheet
' If Not Range("A1:A24").Find(What:="TOOL NUM", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
' Set n = ws.Cells(Rows.count, 1).End(xlUp)
'(3)
'find CUTTING TOOL on the source sheet'
If Not Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
' Set n = ws.Cells(Rows.count, 1).End(xlUp)
' Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
' If Not hc Is Nothing Then
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
End If
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "3"
End If
'(4)
'find HOLDER on the source sheet
Set ws = WB.ActiveSheet
' If Not Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
' Set hc3 = Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues)
Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
If Not hc3 Is Nothing Then
Set dict = GetValues(hc3.Offset(1, 0))
'If InStr(ROW_HEADER, "HOLDER") <> "" Then
If dict.count > 0 Then
'add the values to the master list, column 2
Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "2none"
End If
Else
StartSht.Cells(GetLastRowInColumn(StartSht, "C"), hc1.Column) = "3NO HOLDERS PRESENT!" ' change hc2 to hc1
'StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "NO 'HOLDERS' PRESENT!" ' change hc2 to hc1
End If
'(5)
With WB
'print the file name to Column 4
StartSht.Cells(i, 4) = objFile.Name
With ws
'Print TDS name by searching for header
If Not Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set TDS = Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1)
StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = TDS
Else
StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = objFile.Name
End If
i = GetLastRowInSheet(StartSht) + 1
End With
'(6)
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
End If
'(7)
'move to next file
Next objFile
'turn screen updating back on
Application.ScreenUpdating = True
ActiveWindow.ScrollRow = 1 'brings the viewer to the top of the masterfile
End Sub
'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range, Optional vSplit As Variant) As Object
Dim dict As Object
Dim rng As Range, c As Range
Dim v
Dim spl As Variant
Set dict = CreateObject("scripting.dictionary")
For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
v = Trim(c.Value)
If Not dict.exists(v) Then
If Len(v) > 0 Then
'exclude any info after ";"
If Not IsMissing(vSplit) Then
spl = Split(v, ";")
v = spl(0)
End If
'exclude any info after ","
If Not IsMissing(vSplit) Then
spl = Split(v, ",")
v = spl(0)
End If
End If
dict.Add c.Address, v
End If
If Len(v) = 0 Then
v = "none"
End If
' If Len(v) = "" Then
' v = ""
' End If
Next c
Set GetValues = dict
End Function
'(9)
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
Dim rv As Range, c As Range
For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
'copy cell value if it contains some string "holder" or "cutting tool"
If InStr(c.Value, sHeader) <> 0 Then
Set rv = c
Exit For
End If
Next c
Set HeaderCell = rv
End Function
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
With theWorksheet
GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
End With
End Function
'(11)
Function GetLastRowInSheet(theWorksheet As Worksheet)
Dim ret
With theWorksheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ret = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
ret = 1
End If
End With
GetLastRowInSheet = ret
End Function
”（3）
“在源工作表上查找刀具”
如果不是范围（“A1:M15”）.Find（What:=“切割工具”，LookAt:=xlother，LookIn:=xlValues）则为空
设置hc=范围（“A1:M15”）。查找（内容：=“刀具”，注视：=xlother，注视：=xlValues）
'Set n=ws.Cells（Rows.count，1）.End（xlUp）
'设置hc=收割台单元格（ws.Cells（行标题，1），“切削刀具”）
“如果不是，那么hc什么都不是
Set dict=GetValues（hc.Offset（1,0），“SplitMe”）
如果dict.count>0，则
'将值添加到主列表第3列
Set d=StartSht.Cells（Rows.count，hc2.Column）。End（xlUp）。Offset（1，0）
d、 调整大小（dict.count，1）.Value=Application.Transpose（dict.items）
其他的
StartSht.Cells（Rows.count，hc2.Column）。End（xlUp）。Offset（1，0）=“2”
如果结束
其他的
StartSht.Cells（Rows.count，hc2.Column）。End（xlUp）。Offset（1，0）=“3”
如果结束
'(4)
'在源工作表上查找HOLDER
设置ws=WB.ActiveSheet
如果不是范围（“A1:M15”）.Find（What:=“HOLDER”，LookAt:=xlother，LookIn:=xlValues）则为空
设置hc3=Range（“A1:M15”）。查找（What:=“HOLDER”，LookAt:=xlother，LookIn:=xlValues）
'设置hc3=表头单元格（ws.Cells（行标题，1），“HOLDER”）
“如果不是，那么hc3什么都不是
Set dict=GetValues（hc3.Offset（1,0））
“如果仪表（行标题，“持有人”）”，则
如果dict.count>0，则
'将值添加到主列表第2列
Set d=StartSht.Cells（Rows.count，hc1.Column）。End（xlUp）。Offset（1，0）
d、 调整大小（dict.count，1）.Value=Application.Transpose（dict.items）
其他的
StartSht.Cells（Rows.count，hc1.Column）。End（xlUp）。Offset（1，0）=“2none”
如果结束
其他的
StartSht.Cells（GetLastRowInColumn（StartSht，“C”），hc1.Column）=“不存在任何保持架！”“将hc2更改为hc1
'StartSht.Cells（Rows.count，hc1.Column）。End（xlUp）。Offset（1，0）=“不存在持有人！”'将hc2更改为hc1
如果结束
'(3)
'find CUTTING TOOL on the source sheet'
If Not Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
' Set n = ws.Cells(Rows.count, 1).End(xlUp)
' Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
' If Not hc Is Nothing Then
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
End If
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "3"
End If
'(4)
'find HOLDER on the source sheet
Set ws = WB.ActiveSheet
If Not Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc3 = Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues)
'Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
'If Not hc3 Is Nothing Then
Set dict = GetValues(hc3.Offset(1, 0))
'If InStr(ROW_HEADER, "HOLDER") <> "" Then
If dict.count > 0 Then
'add the values to the master list, column 2
Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "2none"
End If
Else
StartSht.Cells(GetLastRowInColumn(StartSht, "C"), hc1.Column) = "NO HOLDERS PRESENT!" ' change hc2 to hc1
'StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "NO 'HOLDERS' PRESENT!" ' change hc2 to hc1
End If
Option Explicit
Sub LoopThroughDirectory()
Const ROW_HEADER As Long = 10
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim dict As Object
Dim MyFolder As String
Dim f As String
Dim StartSht As Worksheet, ws As Worksheet
Dim WB As Workbook
Dim i As Integer
Dim LastRow As Integer, erow As Integer
Dim Height As Integer
Dim FinalRow As Long
Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, d As Range
Dim TDS As Range
Dim n As Range
Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
'turn screen updating off - makes program faster
Application.ScreenUpdating = False
'location of the folder in which the desired TDS files are
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
'find the headers on the sheet
Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")
Set hc4 = HeaderCell(StartSht.Range("A1"), "TOOLING DATA SHEET (TDS):")
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 2
'loop through directory file and print names
'(1)
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'(2)
'Open folder and file name, do not update links
Set WB = Workbooks.Open(fileName:=MyFolder & objFile.Name, UpdateLinks:=0)
Set ws = WB.ActiveSheet
' If Not Range("A1:A24").Find(What:="TOOL NUM", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
' Set n = ws.Cells(Rows.count, 1).End(xlUp)
'(3)
'find CUTTING TOOL on the source sheet'
If Not Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
' Set n = ws.Cells(Rows.count, 1).End(xlUp)
' Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
' If Not hc Is Nothing Then
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
End If
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "3"
End If
'(4)
'find HOLDER on the source sheet
Set ws = WB.ActiveSheet
' If Not Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
' Set hc3 = Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues)
Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
If Not hc3 Is Nothing Then
Set dict = GetValues(hc3.Offset(1, 0))
'If InStr(ROW_HEADER, "HOLDER") <> "" Then
If dict.count > 0 Then
'add the values to the master list, column 2
Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "2none"
End If
Else
StartSht.Cells(GetLastRowInColumn(StartSht, "C"), hc1.Column) = "3NO HOLDERS PRESENT!" ' change hc2 to hc1
'StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "NO 'HOLDERS' PRESENT!" ' change hc2 to hc1
End If
'(5)
With WB
'print the file name to Column 4
StartSht.Cells(i, 4) = objFile.Name
With ws
'Print TDS name by searching for header
If Not Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set TDS = Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1)
StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = TDS
Else
StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = objFile.Name
End If
i = GetLastRowInSheet(StartSht) + 1
End With
'(6)
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
End If
'(7)
'move to next file
Next objFile
'turn screen updating back on
Application.ScreenUpdating = True
ActiveWindow.ScrollRow = 1 'brings the viewer to the top of the masterfile
End Sub
'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range, Optional vSplit As Variant) As Object
Dim dict As Object
Dim rng As Range, c As Range
Dim v
Dim spl As Variant
Set dict = CreateObject("scripting.dictionary")
For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
v = Trim(c.Value)
If Not dict.exists(v) Then
If Len(v) > 0 Then
'exclude any info after ";"
If Not IsMissing(vSplit) Then
spl = Split(v, ";")
v = spl(0)
End If
'exclude any info after ","
If Not IsMissing(vSplit) Then
spl = Split(v, ",")
v = spl(0)
End If
End If
dict.Add c.Address, v
End If
If Len(v) = 0 Then
v = "none"
End If
' If Len(v) = "" Then
' v = ""
' End If
Next c
Set GetValues = dict
End Function
'(9)
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
Dim rv As Range, c As Range
For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
'copy cell value if it contains some string "holder" or "cutting tool"
If InStr(c.Value, sHeader) <> 0 Then
Set rv = c
Exit For
End If
Next c
Set HeaderCell = rv
End Function
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
With theWorksheet
GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
End With
End Function
'(11)
Function GetLastRowInSheet(theWorksheet As Worksheet)
Dim ret
With theWorksheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ret = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
ret = 1
End If
End With
GetLastRowInSheet = ret
End Function
选项显式
子循环目录（）
Const行标题长度=10
作为对象的Dim objFSO
将文件夹变暗为对象
Dim objFile作为对象
作为对象的Dim dict
将MyFolder设置为字符串
作为字符串的Dim f
Dim StartSht作为工作表，ws作为工作表
将WB设置为工作簿
作为整数的Dim i
将最后一行设置为整数，将eRoom设置为整数
变暗高度为整数
暗淡的最后一行
调光hc作为量程，hc1作为量程，hc2作为量程，hc3作为量程，hc4作为量程，d作为量程
变暗TDS As范围
调光范围
Set StartSht=工作簿（“masterfile.xlsm”）.Sheets（“Sheet1”）
'关闭屏幕更新-使程序更快
Application.ScreenUpdating=False
'所需TDS文件所在文件夹的位置
MyFolder=“C:\Users\trembos\Documents\TDS\progress\”
'查找工作表上的标题
设置hc1=头部电池（起始高度范围（“B1”），“支架”）
设定hc2=头槽（起始高度范围（“C1”），“刀具”）
设置hc4=头槽（起始高度范围（“A1”），“工装数据表（TDS）：”）
'创建FileSystemObject的实例
设置objFSO=CreateObject（“Scripting.FileSystemObject”）
'获取文件夹对象
设置objFolder=objFSO.GetFolder（MyFolder）
i=2
'循环浏览目录文件并打印名称
'(1)
对于objFolder.Files中的每个objFile
如果LCase（Right（objFile.Name，3））=“xls”或LCase（Left（Right（objFile.Name，4），3））=“xls”，则
'(2)
'打开文件夹和文件名，不更新链接
设置WB=Workbooks.Open（文件名：=MyFolder&objFile.Name，UpdateLinks:=0）
设置ws=WB.ActiveSheet
'If Not Range（“A1:A24”）.Find（What:=“TOOL NUM”，LookAt:=xlother，LookIn:=xlValues）则为零
'Set n=ws.Cells（Rows.count，1）.End（xlUp）
'(3)
“在源工作表上查找刀具”
如果不是范围（“A1:M15”）.Find（What:=“切割工具”，LookAt:=xlother，LookIn:=xlValues）则为空
设置hc=范围（“A1:M15”）。查找（内容：=“刀具”，注视：=xlother，注视：=xlValues）
'Set n=ws.Cells（Rows.count，1）.End（xlUp）
'设置hc=收割台单元格（ws.Cells（行标题，1），“切削刀具”）
“如果不是，那么hc什么都不是
Set dict=GetValues（hc.Offset（1,0），“SplitMe”）
如果dict.count>0，则
'将值添加到主列表第3列
Set d=StartSht.Cells（Rows.count，hc2.Column）。End（xlUp）。Offset（1，0）
d、 调整大小（dict.count，1）.Value=Application.Transpose（dict.items）
其他的
s