VBA – 激活打开的文件
我有一个工作的macros，通过文件夹循环打开文件，并从名称“持有人”和“切割工具”列中获得重要的信息，并打印所有的信息到一个Excel文档，masterfile。 它还将文件名称打印到第1栏中，并将“工具数据表”的名称打印在第4栏中。
我正在创build一个button，在一个文件上运行search，您可以键入到一个文本框中。 除了打开文件，读取文件并将其保持打开状态之外，它完美地工作。 我想要它closures文件，但我的主文件是活动工作表。 我无法将打开的文件设置为特定的名称，因为它需要打开我打开的任何一个文件，而不仅仅是一个特定的文件。
任何想法如何切换活动工作表没有一个特定的名字？
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 Workbook = ThisWorkbook 'Copy the range we are interested in 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 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") '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 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 '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 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 'header not found on source worksheet End If '(5) With ws 'print TDS information 'print the file name to Column 1 StartSht.Cells(i, 1) = TextBox1.Text StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = TextBox1.Text 'print TDS name from J1 cell to Column 4 'With ws .Range("J1").Copy StartSht.Cells(i, 4) .Range("J1").Copy StartSht.Range(StartSht.Cells(i, 4), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 4)) 'End With i = GetLastRowInSheet(StartSht) + 1 'move to next file '(6) 'close, do not save any changes to the opened files StartSht.d 'SaveChanges:=False 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 您的代码中已经有了答案：
set wb=workbooks.open...
当你不需要它了，只是wb.close 。
另一种方法是循环浏览所有打开的工作簿并检查其名称：
For Each wb In Application.Workbooks
If wb.name=textbox1.text Then wb.close
Next wb