2015-06-03 112 views
0

我已經編寫了輸出三列信息以及打印文件名的程序的代碼。我通常在該文件夾中運行20個文件的程序,所以我不會用太多的信息壓垮事情,因爲有超過2000個文件。VBA - 可以創建一個鏈接到代碼的按鈕?

是否可以創建一個按鈕,它將輸出相同的信息,但僅用於單個文件名輸入?我希望能夠在搜索中鍵入文件名,並搜索超過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 
+0

如果我理解正確,您希望在工作表中有一個按鈕將運行VBA /宏的Excel文件? – IMTheNachoMan

+0

是的,我相信如此。我對VBA不是非常熟悉,這就是爲什麼這個猶豫不決。但是,是的,這聽起來很準確 – Taylor

+0

嗨泰勒。對的,這是可能的。 http://www.techonthenet.com/excel/formulas/dir.php https://msdn.microsoft.com/en-us/library/office/ff194819.aspx http://stackoverflow.com/questions/20212582/將宏指定給按鈕將一個按鈕添加到工作表(開發人員選項卡 - >插入)https://msdn.microsoft.com/en-us/library/ bb608625。aspx右鍵單擊按鈕,選擇「分配宏」選擇您的宏,然後單擊確定 – user1274820

回答

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

文件的工作表Sheet1 Tools1.xlsx:

​​

創建按鈕並指定宏:

Button and Macro

編輯:

首先,決定你的「搜索單元」 「 將會。

我在Sheet("Sheet1")上選擇了Range("C3"),上面的例子是任意的,但你的可以是任何單元格。

然後,使用上面的代碼搜索並打開它(所有這些都在分配給按鈕的宏中 - 請參閱屏幕截圖瞭解如何將宏指定給按鈕)。

而不是使用行:

'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

+0

因此,我將已寫入的代碼分配給該按鈕以及您在上面鍵入的代碼...文本框插入? – Taylor

+0

如果你想TDS搜索按鈕打開一個文件,那麼你會想要使用像我提供的例子。如果您希望TDS Search按鈕運行您的代碼,您可能需要添加一些代碼來檢查File:字段是否爲空(如果它們沒有輸入文件並單擊您的按鈕,它會運行您的代碼代碼 - 如果他們輸入文件並單擊該按鈕,則會搜索該文件。)那是您想知道的嗎?如果您希望能夠運行兩種不同的功能,則還可以添加第二個按鈕。 – user1274820

+0

我的代碼當前打開文件夾中的每個文件(逐個),將重要信息打印到第2,3和4列,然後將該特定文件的名稱打印到第1列。我希望它能夠鍵入文件名放入一個文本框中,然後它將搜索該文件夾以打開該特定文件,並打印該文件的重要信息。我希望我能更好地解釋它。那有意義嗎? @ user1274820 – Taylor

相關問題