我有工作代码，我改为使用文本框按钮。一切都运作良好，除了我试图从一个抓住标题的范围打印＆＃34; TOOLING DATA SHEET（TDS）：＆＃34;并将其右侧的单元格打印到我的mastefile。
ISSUE： 它与我的原始代码完美配合，可以打开多个文件来打印信息。但是，尝试将其应用到我输入文件名的文本框中时，它会打印出应该打印工具名称的单词HOLDER，即＆＃34; TDS-2343298＆＃34;。我无法弄清楚它甚至在哪里抓住了HOLDER这个词，更不用说为什么我的范围在这个文本框中工作时我的多个文件代码无法正常工作。似乎打印错误的行就是这个区域（在我的代码的第（5）节中）：
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
有什么想法吗？ 修改 问题是它是从错误的工作表读取所以我需要切换活动工作表...有关如何执行此代码的任何建议吗？
代码的摘要：
使用文本框：在文本框中键入文件名，搜索文件夹并打开该文件，然后从名称栏中获取重要信息＆＃34; HOLDER＆＃34;和＆＃34;切割工具＆＃34;通过搜索标题并将该标题下的所有信息打印到一个excel文档masterfile中。它还将文件名打印到第4列，以及＆＃34;工具数据表＆＃34;的名称。第1栏。
通过多个文件运行 循环文件夹打开文件并从名称栏中获取重要信息＆＃34; HOLDER＆＃34;和＃34; CUTTING TOOL＆＃34;通过搜索标题并将该标题下的所有信息打印到一个excel文档masterfile中。它还将文件名打印到第4列，以及＆＃34;工具数据表＆＃34;的名称。第1栏。
使用文本框的完整代码：
Private Sub CommandButton1_Click()
'Set folder path where the file is located
Const TDS_PATH = "C:\Users\trembos\Documents\TDS\progress\"
'Clear out any info on current page
Sheets("Sheet1").Range("A2:D7557").Clear
'TextBox1.Text = ".xlsx"
'TextBox1.Font.Italic = True
'input checking
If TextBox1.Text = "" Then
MsgBox ("Please enter a file to search for")
End If
'Dim WB As Workbook
'Set WB = Workbooks.Open(objFile.Name, UpdateLinks:=0)
'Set ws = WB.ActiveSheet
'If the File we are searching for exists in the path
If TextBox1.Text <> "" Then
'Disable screen updating for performance/aesthetics
Application.ScreenUpdating = False
'Open the workbook we searched for (ReadOnly)
Workbooks.Open TDS_PATH & TextBox1.Text, ReadOnly:=True
Set WrkBk = Workbooks.Open(TDS_PATH & TextBox1.Text)
'Set WrkBk = Workbooks.Open(TextBox1.Text)
'Workbooks.Open objFile.Name
'Copy the range we are interested in
'Dim OpenSht As Worksheet
Const ROW_HEADER As Long = 10
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder 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 f As String
Dim dict As Object
Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, hc5 As Range, d As Range
Dim TDS As Range
Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
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
'Set WB = Workbooks
Set ws = ActiveSheet
'Set WB = Workbooks.Open(fileName:=MyFolder & objFile.NameUpdateLinks:=0)
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
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
'add the values to the master list, column 3
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
End If
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO 'CUTTING TOOL' PRESENT!"
End If
'(4)
'find HOLDER on the source sheet
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
Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
'add the values to the master list, column 2
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
End If
'End If
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO 'CUTTING TOOL' PRESENT!"
End If
'(5)
With ws
'print TDS information
'print the file name to Column 1
StartSht.Cells(i, 4) = TextBox1.Text
'print TDS name from J1 cell to Column 4
With WrkBk
'On Error GoTo ErrorHandler
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)) = "NO TDS VALUE!"
End If
i = GetLastRowInSheet(StartSht) + 1
End With
'(6)
'close, do not save any changes to the opened files
WrkBk.Close 'SaveChanges:=False
'Not StartSht = Close
' If ActiveWorkbook <> StartSht Then
' ActiveWorkbook.Close False
' End If
End With
End If
'(7)
'turn screen updating back on
ActiveWindow.ScrollRow = 1
'Re-enable screen updating
Application.ScreenUpdating = True
'Let the user know if the file is not found
If TextBox1.Text = "" Then
MsgBox ("File not found!")
End If
End Sub
'Private Sub TextBox1_GotFocus()
' TextBox1.Text = ""
' TextBox1.Font.Italic = False
'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 Len(v) > 0 And Not dict.exists(v) 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
dict.Add c.Address, 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
'(10)
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
通过多个文件运行的完整工作代码：
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
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
'(3)
'find CUTTING TOOL on the source sheet
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)
End If
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO 'CUTTING TOOL' PRESENT!"
End If
'(4)
'find HOLDER on the source sheet
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)
End If
'End If
Else
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO 'CUTTING TOOL' PRESENT!"
End If
'(5)
With WB
'print TDS information
'For Each ws In .Worksheets
'print the file name to Column 4
StartSht.Cells(i, 4) = objFile.Name
'Search for "TOOLING DATA SHEET (TDS):", move one column to the right, print info to masterfile column 1
'If Not TDS Is Nothing Then
'ValueToFind = "TOOLING DATA SHEET (TDS):"
' 'Set TDS = Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1)
' If Not IsError(Application.Match("TOOLING DATA SHEET(TDS):", Range("A1:K1"), 0)) Then
' 'If Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues) Then
' StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = ""
' Else
' 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
' End If
' Dim p As Long
' With ws
' If CBool(Application.CountIf(.Rows(ROW_HEADER), "TOOLING DATA SHEET (TDS):")) Then
' p = Application.Match("TOOLING DATA SHEET (TDS):", .Rows(ROW_HEADER), 0)
' StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = p
' Else
' StartSht.Cells(i, 1) = 1
' End If
' End With
With ws
'On Error GoTo ErrorHandler
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)) = "NO TDS VALUE!"
End If
i = GetLastRowInSheet(StartSht) + 1
End With
'End If
'move to next file
'Next ws
'(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 Len(v) > 0 And Not dict.exists(v) 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
dict.Add c.Address, 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
'(10)
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
答案 0 :(得分：0)
在您的代码示例中，无法分辨哪个工作簿＆amp;正在搜索工作表。您还在运行搜索两次。使用＆＃34; book_name.xlsm＆＃34;的相关值，将代码更改为下面的显示方式。和＆＃34; sheet_name＆＃34;。
Dim headingFound As Range
Set headingFound = Workbooks("book_name.xlsm").Worksheets("sheet_name")Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues)
If Not headingFound Is Nothing Then
Set TDS = headingFound.Offset(ColumnOffset:=1)
StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)).Value = TDS.Value