VBA – 获取单元格值，看看是否存在另一个工作簿的列
我有一个文件夹中的许多文档和一个Excel文件中类似但不同的列表。 文件夹中的文档不一定名称正确，但其中一个单元格中的值具有准确的名称。
END GOAL： 我想要做的是让代码遍历该文件夹，打开每个文件，查看单元格中的文件名*（下面的代码部分）*，并将其与另一个Excel文件中的列A进行比较， ACTIVE_FILES.xls。 如果它在列表中，它将移动到下一个文件。 如果它不在列表中，它将从该文件夹中删除该文件。
我已经有工作代码循环通过一个文件夹打开文件，并从他们输出信息。 我只是不知道如何做一个单独的Excel工作表comparisson或如何删除文件夹中的文件，如果它不存在。
当前代码：
这是我目前的代码开始循环通过文件夹（硬编码到MyFolder）打开文件：
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 然后，这是我如何获取包含我正在寻找的文件名的单元格值
（search头文件“TOOLING DATA SHEET（TDS）：”，然后把单元格的值抓取到头部单元格的右边。在我之前的代码中，它将把它打印到列C中的下一个可用行更长的时间需要，但我一直在显示我的GetLastRowInColumn函数，这可能有助于search我想要执行的计划中的列A）
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
最后，这里是我的function，帮助使这一切成为可能。 数字指定一个新的function，并在每个旁边有一个解释。
'(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
编辑显示新的作品
潜在的代码1：移动不需要的文件到另一个文件夹 – 不工作，基本轮廓，因为我不知道如何比较我上面说的testing运行
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
您可以将工作簿ACTIVE_FILES设置为工作簿对象。 所以也许你把它叫做WBREF，并且把工作表ACTIVE_FILES命名为工作表对象，比如WSREF。 那么你可以编写如下代码：
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
编辑：让我解释一下这段代码的作用：对于列1中的所有行（你应该编写LastRow，只要在这个站点上search它，你会发现如何做），它检查单元格的内容是否与值的TDS。 如果发现匹配，则closures文件并停止查找。 如果第一行不匹配，它会移动到第二行等等。如果它到达最后一行（这是ElseIf后面的代码部分），并且这行也不匹配，那么在这里编码如何删除文件。
所以你需要把这个代码循环放到你已经提取了TDS的循环中，之后它需要运行这个循环，然后再进入下一个TDS。
你的问题有点长，但是我想你可以使用这里描述的函数GetInfoFromClosedFile() 。