使用文本框控件搜索文件并执行宏
search for file and execute macro using a textbox control
我正在尝试在 excel sheet 主文件中使用文本框和搜索按钮。我希望能够在文本框中输入文件名并点击搜索按钮并让它在特定文件夹中搜索该文件，打开文件，然后 运行 我在该文件上的宏（从中收集数据sheet 并将其放入我的主文件并关闭文件）。
我已经编写了代码，但是这一行 If Dir(TDS_PATH & TextBox1.Text) <> "" Then 会被跳过并传递给 Else，即使文本框不为空也是如此……很明显它一定认为它是空的？提前感谢您的帮助！
谁能帮我找出我哪里出错了？
该图像是我的主文件的样子，我的代码是用于搜索按钮和我的宏
更新
我已经获得了正确打开文件的按钮，但我正在尝试更改我的宏以使其正确读取/使其与下一个文本框打开文件方法兼容，但它无法正常工作，更多信息在下面的评论中。有什么想法吗？
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 = "Enter File Name Here"
'TextBox1.Font.Italic = True
'input checking
If TextBox1.Text = "" Then
MsgBox ("Please enter a file to search for")
End If
'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
'Copy the range we are interested in
ActiveWorkbook.Application.Run "Search"
'Close the file
ActiveWorkbook.Close (False)
'Re-enable screen updating
Application.ScreenUpdating = True
Else
'Let the user know if the file is not found
MsgBox ("File not found!")
End If
End Sub
Private Sub TextBox1_GotFocus()
TextBox1.Text = ""
TextBox1.Font.Italic = False
End Sub
我的宏代码在这里：
Option Explicit
Sub Search()
Const ROW_HEADER As Long = 10
Dim objFSO As Object
Dim objFolder As Object
Dim MyFolder As String
Dim objFile As Object
Dim WB As Workbook
Dim dict As Object
Dim i As Integer
Dim StartSht As Worksheet, ws As Worksheet
Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d As Range
Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
i = 2
'(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))
If dict.count > 0 Then
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
'add the values to the masterfile, column 3
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
End If
Else
'header not found on source worksheet
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 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
Else
'header not found on source worksheet
End If
'(5)
With WB
'print TDS information
For Each ws In .Worksheets
'print the file name to Column 1
StartSht.Cells(i, 1) = objFile.Name
'print TDS name from J1 cell to Column 4
With ws
.Range("J1").Copy StartSht.Cells(i, 4)
End With
i = GetLastRowInSheet(StartSht) + 1
'move to next file
Next ws
'(6)
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
'turn screen updating back on
Application.ScreenUpdating = True
ActiveWindow.ScrollRow = 1
'(7)
End Sub
'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range) As Object
Dim dict As Object, rng As Range, c As Range, v
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
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
If Trim(c.Value) = sHeader 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
文本框为空或找不到文件。
您是否在文件名末尾添加 .xls？
您可以在代码末尾添加一个通配符，这样您就不必每次都输入文件扩展名了。
If Dir(TDS_PATH & TextBox1.Text & "*") <> "" Then
解决方案
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
'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
'Copy the range we are interested in
ActiveWorkbook.Application.Run "Search"
'Close the file
ActiveWorkbook.Close (False)
'Re-enable screen updating
Application.ScreenUpdating = True
Else
'Let the user know if the file is not found
MsgBox ("File not found!")
End If
End Sub
'if you click on the textbox, it will empty any contents
Private Sub TextBox1_GotFocus()
TextBox1.Text = ""
TextBox1.Font.Italic = False
End Sub
我正在尝试在 excel sheet 主文件中使用文本框和搜索按钮。我希望能够在文本框中输入文件名并点击搜索按钮并让它在特定文件夹中搜索该文件，打开文件，然后 运行 我在该文件上的宏（从中收集数据sheet 并将其放入我的主文件并关闭文件）。
我已经编写了代码，但是这一行 If Dir(TDS_PATH & TextBox1.Text) <> "" Then 会被跳过并传递给 Else，即使文本框不为空也是如此……很明显它一定认为它是空的？提前感谢您的帮助！
谁能帮我找出我哪里出错了？ 该图像是我的主文件的样子，我的代码是用于搜索按钮和我的宏
更新 我已经获得了正确打开文件的按钮，但我正在尝试更改我的宏以使其正确读取/使其与下一个文本框打开文件方法兼容，但它无法正常工作，更多信息在下面的评论中。有什么想法吗？
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 = "Enter File Name Here"
'TextBox1.Font.Italic = True
'input checking
If TextBox1.Text = "" Then
MsgBox ("Please enter a file to search for")
End If
'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
'Copy the range we are interested in
ActiveWorkbook.Application.Run "Search"
'Close the file
ActiveWorkbook.Close (False)
'Re-enable screen updating
Application.ScreenUpdating = True
Else
'Let the user know if the file is not found
MsgBox ("File not found!")
End If
End Sub
Private Sub TextBox1_GotFocus()
TextBox1.Text = ""
TextBox1.Font.Italic = False
End Sub
我的宏代码在这里：
Option Explicit
Sub Search()
Const ROW_HEADER As Long = 10
Dim objFSO As Object
Dim objFolder As Object
Dim MyFolder As String
Dim objFile As Object
Dim WB As Workbook
Dim dict As Object
Dim i As Integer
Dim StartSht As Worksheet, ws As Worksheet
Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d As Range
Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
i = 2
'(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))
If dict.count > 0 Then
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
'add the values to the masterfile, column 3
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
End If
Else
'header not found on source worksheet
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 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
Else
'header not found on source worksheet
End If
'(5)
With WB
'print TDS information
For Each ws In .Worksheets
'print the file name to Column 1
StartSht.Cells(i, 1) = objFile.Name
'print TDS name from J1 cell to Column 4
With ws
.Range("J1").Copy StartSht.Cells(i, 4)
End With
i = GetLastRowInSheet(StartSht) + 1
'move to next file
Next ws
'(6)
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
'turn screen updating back on
Application.ScreenUpdating = True
ActiveWindow.ScrollRow = 1
'(7)
End Sub
'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range) As Object
Dim dict As Object, rng As Range, c As Range, v
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
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
If Trim(c.Value) = sHeader 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
文本框为空或找不到文件。
您是否在文件名末尾添加 .xls？
您可以在代码末尾添加一个通配符，这样您就不必每次都输入文件扩展名了。
If Dir(TDS_PATH & TextBox1.Text & "*") <> "" Then
解决方案
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
'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
'Copy the range we are interested in
ActiveWorkbook.Application.Run "Search"
'Close the file
ActiveWorkbook.Close (False)
'Re-enable screen updating
Application.ScreenUpdating = True
Else
'Let the user know if the file is not found
MsgBox ("File not found!")
End If
End Sub
'if you click on the textbox, it will empty any contents
Private Sub TextBox1_GotFocus()
TextBox1.Text = ""
TextBox1.Font.Italic = False
End Sub