[英]VBA - get cell value, see if present in column of another workbook
我在一个文件夹中有许多文档,在Excel文件中有一个相似但不同的列表。 文件夹中的文档并非总是正确地命名,但是其中一个单元格中的值具有正确的名称。
结束目标: 我要做的是让代码遍历该文件夹,打开每个文件,查看单元格中的文件名*(下面该部分的代码)*,并将其与另一个Excel文件中的A列进行比较, ACTIVE_FILES.xls。 如果在列表中,它将移至下一个文件。 如果不在列表中,它将从文件夹中删除该文件。
我已经有工作代码,该代码循环通过一个文件夹打开文件并从中输出信息。 我只是不知道如何对一个单独的Excel工作表进行比较,或者不存在的情况下如何从一个文件夹中删除一个文件 。
当前代码:
这是我当前代码从循环遍历文件夹(硬编码到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
然后,这就是我如何获取包含要查找的文件名的单元格值
(搜索标题“ TOOLING DATA SHEET(TDS):”,然后获取该标题单元格右侧的单元格的值。在我之前的代码中,它将把它打印到C列中的下一个可用行,即否需要更长的时间,但我继续展示我的GetLastRowInColumn函数,该函数可以帮助在我要执行的计划中搜索列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
最后,这是我的功能,有助于使一切变为可能。 数字表示一项新功能,每项旁边都有一个说明。
'(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:将不需要的文件移动到另一个文件夹-不起作用,基本概述,因为我不知道如何比较上面所述的内容以测试运行
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进行编码,只需在此站点上搜索它,然后您将找到相应的方式),它将检查单元格的内容是否与值匹配TDS。 如果找到匹配项,则关闭文件并停止查找。 如果第一行不匹配,则移至第二行, ElseIf
。如果到达最后一行(这是ElseIf
后面的代码部分),并且此行也不匹配,则在此处编码如何删除文件。
因此,您需要将此代码循环放在提取TDS的循环中,紧接着它需要运行此代码,然后再继续进行下一个TDS。
您的问题有点长,但我认为您可能会使用此处介绍的GetInfoFromClosedFile()
函数。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.