Taylor
Taylor

Reputation: 181

VBA - Activate open file

I have a working macro that loops through folder to open files and get important info from the columns of names "HOLDER" and "CUTTING TOOL" and printing all the info to one excel document, masterfile. It also prints the file name into column 1 and the name of the "Tooling Data Sheet" to column 4.

I am creating a button that runs a search on one file that you can type into a textbox. It works perfectly except it opens a file, reads it, and leaves it open. I want it to close the file but my masterfile is the active sheet. I cannot set the open file as a specific name because it needs to open whatever one file I open, not just one specific file.

Any ideas how to switch the active sheet without a specific name?

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

Upvotes: 0

Views: 2555

Answers (1)

You already have the answer in your code:
set wb=workbooks.open...
and when you don't need it anymore just wb.close.

Another approach could be to loop through all open workbook's and check their names:
For Each wb In Application.Workbooks
If wb.name=textbox1.text Then wb.close
Next wb

Upvotes: 2

Related Questions