Question

我编写了一个程序的代码，该程序输出三列信息以及打印文件名。我通常在文件夹中运行20个文件的程序，所以我不会用太多的信息来淹没，因为有超过2000个文件。

是否可以创建一个按钮，输出相同的信息但只输入一个文件名？我希望能够输入文件名，点击搜索，并让它搜索超过2000个文件的文件夹，以输出那些特定文件的三列信息。

看起来像这样的东西： enter image description here

Option Explicit

Sub LoopThroughDirectory()

    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 RowLast As Long
    Dim f As String
    Dim dict As Object
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d As Range

    Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")

    'turn screen updating off - makes program faster
    Application.ScreenUpdating = False
    'Application.UpdateLinks = 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")

    '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)
            'print file name to Column 1

            '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 = GetUniques(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.keys)
                    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 = GetUniques(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.keys)
                    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
        End If
    'move to next file
    Next objFile
    '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 GetUniques(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 v, ""
        End If
    Next c
    Set GetUniques = 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

这是一个简单的例子：

'The directory containing the files
Const TDS_PATH = "C:\Data\TDS Search\"

Sub openFileCopyColumn()

'Clear our list
Sheets("Sheet1").Range("B6:D31").Clear

'Very basic input checking - you can always add more
If Sheets("Sheet1").Range("C3") = "" Then
    MsgBox("Please enter a file to search for")
    Exit Sub
End If

'If the File we are searching for exists in the path
If Dir(TDS_PATH & Sheets("Sheet1").Range("C3")) <> "" Then

    'Disable screen updating for performance/aesthetics
    Application.ScreenUpdating = False

    'Open the workbook we searched for (ReadOnly)
    Workbooks.Open TDS_PATH & Sheets("Sheet1").Range("C3"), ReadOnly:=True

    'Copy the range we are interested in
    ActiveWorkbook.Sheets("Sheet1").Range("A2:C16").Copy ThisWorkbook.Sheets("Sheet1").Range("B6")

    '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

TDS搜索工作簿的Sheet1：

TDS Search

File Tools1.xlsx的Sheet1：

Tools

创建按钮并指定宏：

Button and Macro

修改

首先，确定您的“搜索单元”将是什么。

我在上面的示例中任意选择Range("C3") Sheet("Sheet1")，但您的可以是任何单元格。

然后，使用上面的代码搜索并打开它（所有这些都在分配给按钮的宏中 - 请参阅屏幕截图，了解如何将宏指定给按钮）。

而不是使用行：

'Copy the range we are interested in ActiveWorkbook.Sheets("Sheet1").Range("A2:C16").Copy ThisWorkbook.Sheets("Sheet1").Range("B6")

如果我们想运行存储在新打开的工作簿中的宏，我们可以使用：

ActiveWorkbook.Application.Run "MacroName"

这里有更多信息：

http://www.mrexcel.com/forum/excel-questions/51660-calling-macro-another-workbook.html

VBA - 可以创建一个链接到代码的按钮吗？

1 个答案: