[英]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.