Question

我有一个工作宏，它循环遍历文件夹以打开文件并从名称栏中获取重要信息＆＃34; HOLDER＆＃34;和＆＃34;切割工具＆＃34;并将所有信息打印到一个excel文档masterfile。

我遇到的问题是，在“HOLDER”栏中，有时会有额外的信息，如“Holder / Toolbox”，但它不一致。我让它与“HOLDER”一起工作，但我想知道是否仍然可以这样做，无论HOLDER标题名称中是否有额外的文本，或者它是小写而不是所有大写。感谢您提供任何帮助！

这是处理＆＃34; HOLDER＆＃34;的代码。栏目。下面是完整的代码以便更好地参考（第4节关于我正在修改的部分，第8部分是它引用的函数）。

'find the headers on the sheet
Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")

...

'(4)
            'find HOLDER on the source sheet
            Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
            If Not hc3 Is Nothing Then

                Set dict = GetValues(hc3.Offset(1, 0))
                If dict.count > 0 Then
                    Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                    'add the values to the master list, column 2
                    d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                End If
            Else
                'header not found on source worksheet
            End If

...

'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range, Optional vSplit As Variant) As Object
    Dim dict As Object
    Dim rng As Range, c As Range
    Dim v
    Dim spl As Variant

    Set dict = CreateObject("scripting.dictionary")

    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
        v = Trim(c.Value)
        If Len(v) > 0 And Not dict.exists(v) Then

            If Not IsMissing(vSplit) Then
            spl = Split(v, ";")

            v = spl(0)
            End If

            If Not IsMissing(vSplit) Then
            spl = Split(v, ",")

            v = spl(0)
            End If
            dict.Add c.Address, v
        End If
    Next c
    Set GetValues = dict
End Function

完整代码

Option Explicit

Sub LoopThroughDirectory()

    Const ROW_HEADER As Long = 10

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim MyFolder As String
    Dim StartSht As Worksheet, ws As Worksheet
    Dim WB As Workbook
    Dim i As Integer
    Dim LastRow As Integer, erow As Integer
    Dim Height As Integer
    Dim RowLast As Long
    Dim f As String
    Dim dict As Object
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d 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\TDS\progress\"

    'find the headers on the sheet
    Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
    Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")

    '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)
    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
'(3)
                'find CUTTING TOOL on the source sheet
                Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
                If Not hc Is Nothing Then

                    Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
                    If dict.count > 0 Then
                        Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
                        'add the values to the master list, column 3
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    End If
                Else
                    'header not found on source worksheet
                End If
'(4)
                'find HOLDER on the source sheet
                Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
                If Not hc3 Is Nothing Then

                    Set dict = GetValues(hc3.Offset(1, 0))
                    If dict.count > 0 Then
                        Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                        'add the values to the master list, column 2
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    End If
                Else
                    'header not found on source worksheet
                End If
'(5)
            'print filename and TDS information
            With WB
                For Each ws In .Worksheets
                        'print the file name to Column 1
                        StartSht.Cells(i, 1) = objFile.Name
                        StartSht.Cells((GetLastRowInColumn(StartSht, "C")), 1) = objFile.Name

                        'print TDS name from J1 cell to Column 4
                        With ws
                            .Range("J1").Copy StartSht.Cells(i, 4)
                        End With
                        i = GetLastRowInSheet(StartSht) + 1
                'move to next file
                Next ws
'(6)
                'close, do not save any changes to the opened files
                .Close SaveChanges:=False
            End With
        End If
    'move to next file
    Next objFile
    'turn screen updating back on
    Application.ScreenUpdating = True
    ActiveWindow.ScrollRow = 1
'(7)
End Sub

'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range, Optional vSplit As Variant) As Object
    Dim dict As Object
    Dim rng As Range, c As Range
    Dim v
    Dim spl As Variant

    Set dict = CreateObject("scripting.dictionary")

    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
        v = Trim(c.Value)
        If Len(v) > 0 And Not dict.exists(v) Then

            If Not IsMissing(vSplit) Then
            spl = Split(v, ";")

            v = spl(0)
            End If

            If Not IsMissing(vSplit) Then
            spl = Split(v, ",")

            v = spl(0)
            End If
            dict.Add c.Address, v
        End If
    Next c
    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
        If Trim(c.Value) = sHeader Then
            Set rv = c
            Exit For
        End If
    Next c
    Set HeaderCell = rv
End Function

'(10)
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
    With theWorksheet
        GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
    End With
End Function


'(11)
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

Answer 1

好吧，InStr有助于找出字符串中是否包含子字符串。基本上，它返回的是字符串中子字符串的位置;所以，像一条线：

Instr ("hello world!", "h")

将返回1 第一个参数是您要查看的字符串，第二个参数是您要查找的子字符串。

因此，如果返回值不为零，则表示包含子字符串。你会这样检查：

If InStr(string, substring) <> 0 then
'do code
End If

此外，对于区分大小写的情况：

您可能希望将单元格值放入字符串变量中，但转换为大写字母;然后检查“HOLDER”等等。这不会改变单元格中的值，只是为了比较。只是做：

dim uString as String

uString = UCase(c.Value)

Answer 2

需要调整的部分是搜索标题行，比较值的部分。看起来这是在HeaderCell函数中。看起来进行比较的具体行是：

If Trim(c.Value) = sHeader Then

这是将标题行中每个单元格的内容与传入的值进行比较（在您的情况下为sHeader =“Holder”）。

你最好做一个测试，看看sHeader是否在单元格值中，不等于单元格值。 InStr功能非常适合这种情况。（未经测试的航空代码）：

If InStr(c.Value, sHeader) <> 0 Then

这将搜索标题行中每个单元格的内容，查看传入sHeader的值是否在值的任何位置。

VBA - 如果单元格包含某个值而不是等于或不等于，则复制值

2 个答案: