Question

我正在尝试使用Excel工作表中的文本框和搜索按钮。我希望能够在文本框中键入文件名并点击搜索按钮，让它在特定文件夹中搜索该文件，打开文件，然后在该文件上运行我的宏（从文件中收集数据并放入它进入我的主文件并关闭文件。）

我已编写代码，但即使文本框不为空，此行If Dir(TDS_PATH & TextBox1.Text) <> "" Then也会被跳过并传递给Else ...显然它必须认为它是空的？感谢您提前提供任何帮助！

任何人都可以帮我弄明白我哪里错了吗？图像是我的主文件的样子，我的代码是搜索按钮和我的宏

更新我已经获得了正确打开文件的按钮，但我正在尝试更改我的宏以使其正确读取/使其与下一个文本框打开文件方法兼容，但它无法正常工作，更多信息在下面的评论中。有什么想法吗？

enter image description here

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

Answer 1

文本框为空或无法找到文件。

您是否在文件名末尾添加.xls？

您最后可以在代码中添加通配符，这样您就不必每次都输入文件扩展名。

If Dir(TDS_PATH & TextBox1.Text & "*") <> "" Then

Answer 2

<强>解

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

使用文本框控件

2 个答案: