VBA-获取单元格值，查看是否存在于另一个工作簿的列中

Question

I have many documents in a folder and a similar but different list in an Excel file. The documents in the folder are not always name correctly, but the value in one of the cells has the accurate name.

END GOAL: what I want to do is have code that runs through that folder, opens each file, looks at the file name in a cell*(code for that part below)* and compare it to Column A in the other Excel file, ACTIVE_FILES.xls. If it is in the list, it will move on to the next file. If it is not in the list, it will delete that file from the folder.

I already have working code which loops though a folder to open files and output information from them. I just do not know how to do a comparisson to a separate Excel worksheet or how to delete a file from a folder if it is not present.

CURRENT CODE:

This is how my current code starts out with looping through the folder (hard coded into MyFolder) to open files:

Option Explicit

Sub Active()


Sub LoopThroughDirectory()

    Dim objFSO As Object, objFolder As Object, objFile As Object, dict As Object
    Dim MyFolder As String
    Dim StartSht As Worksheet, ws As Worksheet
    Dim WB As Workbook
    Dim i As Integer
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, d As Range, TDS As Range

    Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
    'turn screen updating off - makes program faster
    Application.ScreenUpdating = False

    'location of the folder in which the desired TDS files are
    MyFolder = "C:\Users\trembos\Documents\TDS2\progress\"

    'find the header
    Set hc4 = HeaderCell(StartSht.Range("A1"), "TOOLING DATA SHEET (TDS):")

    '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)
    'code for every excel file in the specified folder
    For Each objFile In objFolder.Files
        If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'(2)
            'Open folder and file name, do not update links
            Set WB = Workbooks.Open(Filename:=MyFolder & objFile.Name, UpdateLinks:=0)
            Set ws = WB.ActiveSheet

Then, this is how I grab the cell value which contains the file name I am looking for

(searches for header "TOOLING DATA SHEET (TDS):" and then grabs the value of the cell to the right of that header cell. In my previous code, it would then print it to the next available row in column C which is no longer needed but I kept in to show my GetLastRowInColumn function which could help search through column A in the plan I want to execute)

With ws
'Print TDS name by searching for header
    If Not ws.Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
        Set TDS = ws.Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1)
        StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = TDS
    Else                
    End If
    i = GetLastRowInSheet(StartSht) + 1
End With

And finally, here are my functions which help make it all possible. Numbers designate a new function and there is an explanation next to each one.

'(8)
'Get the Values from columns with specified headers
Function GetValues(ch As Range, Optional vSplit As Variant) As Scripting.Dictionary
    Dim dict As Scripting.Dictionary
    Dim dataRange As Range, cell As Range
    Dim theValue As String
    Dim splitValues As Variant
    Dim counter As Long
Set dict = New Scripting.Dictionary
Set dataRange = ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
' If there are no values in this column then return an empty dictionary
' If there are no values in this column, the dataRange will start at the row
' *above* ch and end at ch
If (dataRange.Row = (ch.Row - 1)) And (dataRange.Rows.count = 2) And (Trim(ch.Value) = "") Then
    GoTo Exit_Function
End If
For Each cell In dataRange.Cells
    counter = counter + 1
    theValue = Trim(cell.Value)
    If Len(theValue) = 0 Then
        theValue = " "
    End If
        'exclude any info after ";"
        If Not IsMissing(vSplit) Then
            splitValues = Split(theValue, ";")
            theValue = splitValues(0)
        End If
        'exclude any info after ","
        If Not IsMissing(vSplit) Then
            splitValues = Split(theValue, ",")
            theValue = splitValues(0)
        End If
        If Not dict.exists(theValue) Then
        dict.Add counter, theValue
        End If
Next cell
Exit_Function:
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 Trim(c.Value) = sHeader Then
        'If InStr(c.Value, sHeader) <> 0 Then
            Set rv = c
            Exit For
        End If
    Next c
    Set HeaderCell = rv
End Function
'(10)
'gets the last row in designated column
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
    With theWorksheet
        GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
    End With
End Function
'(11)
'gets the last row in designated sheet
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

EDIT TO SHOW NEW WORK

POTENTIAL CODE 1: moving unwanted files to another folder - not working, basic outline because I do not know how to compare what I stated above to test a run

Option Explicit
' 33333

Sub Activate()

    Dim objFSO As Object, objFolder As Object, objFile As Object, dict As Object
    Dim MyFolder As String
    Dim StartSht As Worksheet, ws As Worksheet
    Dim WB As Workbook, wbkA As Workbook
    Dim row As Long, col As Long
    Dim LastRow As Long
    Dim TDS1 As Object




    Dim i As Integer
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, d As Range, TDS As Range

    Set StartSht = Workbooks("Active.xlsm").Sheets("Sheet1")
    'turn screen updating off - makes program faster
'    Application.ScreenUpdating = False

    'location of the folder in which the desired TDS files are
    MyFolder = "C:\Users\trembos\Documents\TDS2\progress_test\"

    'find the headers on the sheet
    Set hc4 = HeaderCell(StartSht.Range("A1"), "TOOLING DATA SHEET (TDS):")

    '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)
    'code for every excel file in the specified folder
    For Each objFile In objFolder.Files
        If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then

        Set wbkA = Workbooks.Open(FileName:="C:\Users\trembos\Documents\TDS2\TDS_ACTIVE_FILES.xls")

        For row = 1 To LastRow
            With WB
                If wbkA.Cells(row, 1).Value <> GetFilenameWithoutExtension(objFile.Name) Then
                ElseIf row = LastRow And wbkA.Cells(row, col) <> TDS.Value Then
                    StartSht.Cells(i, 1) = GetFilenameWithoutExtension(objFile.Name)
                    i = GetLastRowInSheet(StartSht) + 1
                End If
            End With
        Next

    End If
    Next

Answer 1

You can set the workbook ACTIVE_FILES is in as a workbook object. So perhaps you call it WBREF, and also name the worksheet ACTIVE_FILES as a worksheet object, like WSREF. Then you can code something like:

For row = 1 to LastRow 
    IF WBREF.WSREF.Cells(row, *# of column in which your data is*). Value = TDS.Value Then 
        * close file* 
        Exit For 
    ElseIf row = LastRow And WBREF.WSREF.Cells(row,col) <> TDS.Value THEN 
        code how to delete file
    End If
Next row

Edit: Let me explain what this code does: For all rows in column 1 (you should code that LastRow, just search for it on this site and you will find how to do that) it checks if the content of the cell matches the value of TDS. If it finds a match it closes the file and stops looking. If the first row is not a match, it moves to the second row etc. etc. If it arrives at the last row (this is the part of code after ElseIf ) and this row is also not a match you code here how to delete the file.

So you would need to place this loop of code within the loop that you have that extracts the TDS, right after that it needs to run this, before it moves on to the next TDS.

Answer 2

您的问题有点长，但我认为您可能会使用此处介绍的GetInfoFromClosedFile()函数。