1
我有工作代码，我改变了使用文本框按钮。一切运作良好，除了我试图从一个范围内打印头“TOOLING DATA SHEET（TDS）：”并将右边的单元格打印到我的maste文件中。VBA - 从范围打印错误的值
问题： 它与我原来的代码打开多个文件打印出信息的美妙作品。但是，试图将其应用到输入文件名的文本框中，它会在打印工具名称（即“TDS-2343298”）的位置打印出HOLDER字样。我无法弄清楚它甚至抓住了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
任何想法吗？ 编辑： 问题是，它是从错误的表读取，所以我需要切换活动工作表...任何建议如何做到这一点的代码？
摘要什么代码所做的：
使用TEXTBOX：键入文件名到其搜索一个文件夹，打开该文件中的文本框，然后会从名称的列的重要信息“HOLDER”和“CUTTING TOOL”通过搜索标题并将该标题下的所有信息打印到一个excel文档masterfile中。它也打印文件名到第4列和“加工数据表”到第1列
贯穿多个文件的名称： 遍历文件夹中打开文件，并从名称列获取重要信息“HOLDER”和“CUTTING TOOL”通过搜索标题并将该标题下的所有信息打印到一个excel文档masterfile中。它也打印文件名变为第4栏和“工具数据表”，以列的名称1.
全码USING TEXTBOX：
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
FULL工作代码运行的多个文件：
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