Question

我在Excel文件中的文件夹和类似但不同的列表中有很多文档。文件夹中的文档并不总是名称正确，但其中一个单元格中的值具有准确的名称。

结束目标：我想要做的是拥有贯穿该文件夹的代码，打开每个文件，查看单元格中的文件名*（下面该部分的代码）*并将其与A列进行比较在另一个Excel文件中，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

Answer 1

您可以将工作簿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之后的代码的一部分）并且此行也不匹配您的代码这里有如何删除文件。

所以你需要将这个代码循环放在你提取TDS的循环中，之后它需要运行它，然后再转移到下一个TDS。

Answer 2

您的问题有点长，但我认为您可以在SO上使用GetInfoFromClosedFile()所述的__proxy__函数。

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

2 个答案: