[英]VBA - Activate open file
我有一個工作宏,該宏循環遍歷文件夾以打開文件並從名稱“ HOLDER”和“ CUTTING TOOL”的列中獲取重要信息,並將所有信息打印到一個excel文檔masterfile中。 它還將文件名打印到第1列中,並將“工具數據表”的名稱打印到第4列中。
我正在創建一個按鈕,該按鈕在一個文件中運行搜索,您可以在文本框中鍵入該文件。 除了打開文件,讀取文件並使其保持打開狀態之外,它的工作原理非常完美。 我希望它關閉文件,但我的主文件是活動工作表。 我無法將打開文件設置為特定名稱,因為它需要打開我打開的任何一個文件,而不僅僅是一個特定文件。
有什么想法如何在沒有特定名稱的情況下切換活動工作表嗎?
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.