VBA – 从范围打印错误的值
我有工作代码，我修改了一个文本框button。 一切运作良好，除了我试图从一个范围，打印标题“工具数据表（TDS）：”打印，并打印到我的mastefile右侧的单元格。
问题：它与我打开多个文件打印出来的信息的原始代码美丽的作品。 但是，试图将其应用于input文件名的文本框中，在打印工具名称（即“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 有什么想法吗？ 编辑： 问题是它从错误的表中读取，所以我需要切换活动工作表…任何build议如何做到这一点的代码？
什么代码的总结：
使用文本框：在search文件夹的文本框中input一个文件名，然后打开该文件，然后通过search标题和打印所有的信息，从“HOLDER”和“CUTTING TOOL”头文件成一个excel文件，masterfile。 它还将文件名打印到第4栏，并将“工具数据表”的名称打印到第1栏。
通过多个文件运行：通过文件夹循环打开文件，并通过search标题并从该标题下的所有信息打印到一个excel文件masterfile中，从名为“HOLDER”和“CUTTING TOOL”的列中获取重要信息。 它还将文件名打印到第4栏，并将“工具数据表”的名称打印到第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
在您的代码示例中，无法确定正在search哪个工作簿和工作表。 您也正在运行search两次。 将代码更改为如下所示，使用“book_name.xlsm”和“sheet_name”的相关值。
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