Question

I have two sections of code that basically do the same thing but with two different columns. The code finds the header "CUTTING TOOL" and "HOLDER" (looping through multiple files) and prints the information from those columns into one worksheet, masterfile.

I was using a less efficient method of setting a variable to a range and switched to the .Find method. It works for CUTTING TOOL but not for HOLDER and I am unsure why it would be different since the two are almost exactly the same.

CUTTING TOOL works as it should but HOLDER will now only print the word HOLDER where it should print NO HOLDERS PRESENT. Also, it included printing blank cells into my masterfile and now it will not do that. I am not sure where I went wrong.

Here is the particular area of code I am working on:

'(3)
                'find CUTTING TOOL on the source sheet'
                If Not Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
                Set hc = Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
'                Set n = ws.Cells(Rows.count, 1).End(xlUp)
'                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
                    'add the values to the master list, column 3
                        Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    Else
                        StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
                    End If
                Else
                    StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "3"
                End If
'(4)
                'find HOLDER on the source sheet
                Set ws = WB.ActiveSheet
                If Not Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
                Set hc3 = Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues)

                'Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
                'If Not hc3 Is Nothing Then
                    Set dict = GetValues(hc3.Offset(1, 0))
                    'If InStr(ROW_HEADER, "HOLDER") <> "" Then
                    If dict.count > 0 Then
                        'add the values to the master list, column 2
                        Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    Else
                        StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "2none"
                    End If
                Else
                    StartSht.Cells(GetLastRowInColumn(StartSht, "C"), hc1.Column) = "NO HOLDERS PRESENT!" ' change hc2 to hc1
                    'StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "NO 'HOLDERS' PRESENT!" ' change hc2 to hc1
                End If

And here is my full code if you need it:

Option Explicit

Sub LoopThroughDirectory()

    Const ROW_HEADER As Long = 10

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim dict As Object
    Dim MyFolder As String
    Dim f 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 FinalRow As Long
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, d As Range
    Dim TDS As Range

    Dim n 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")
    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)
    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



'            If Not Range("A1:A24").Find(What:="TOOL NUM", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
'                Set n = ws.Cells(Rows.count, 1).End(xlUp)
'(3)
                'find CUTTING TOOL on the source sheet'
                If Not Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
                Set hc = Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
'                Set n = ws.Cells(Rows.count, 1).End(xlUp)
'                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
                    'add the values to the master list, column 3
                        Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    Else
                        StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
                    End If
                Else
                    StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "3"
                End If
'(4)
                'find HOLDER on the source sheet
                Set ws = WB.ActiveSheet
'                If Not Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
'                Set hc3 = Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues)

                Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
                If Not hc3 Is Nothing Then
                    Set dict = GetValues(hc3.Offset(1, 0))
                    'If InStr(ROW_HEADER, "HOLDER") <> "" Then
                    If dict.count > 0 Then
                        'add the values to the master list, column 2
                        Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    Else
                        StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "2none"
                    End If
                Else
                    StartSht.Cells(GetLastRowInColumn(StartSht, "C"), hc1.Column) = "3NO HOLDERS PRESENT!" ' change hc2 to hc1
                    'StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "NO 'HOLDERS' PRESENT!" ' change hc2 to hc1
                End If
'(5)
            With WB
                    'print the file name to Column 4
                    StartSht.Cells(i, 4) = objFile.Name

                    With ws
                    'Print TDS name by searching for header
                        If Not Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
                            Set TDS = 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
                            StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = objFile.Name
                        End If
                        i = GetLastRowInSheet(StartSht) + 1
                    End With


'(6)
                'close, do not save any changes to the opened files
                .Close SaveChanges:=False
            End With
        End If
'(7)
    'move to next file
    Next objFile
    'turn screen updating back on
    Application.ScreenUpdating = True
    ActiveWindow.ScrollRow = 1 'brings the viewer to the top of the masterfile
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 Not dict.exists(v) Then
                If Len(v) > 0 Then

            'exclude any info after ";"
            If Not IsMissing(vSplit) Then
                spl = Split(v, ";")
                v = spl(0)
            End If

            'exclude any info after ","
            If Not IsMissing(vSplit) Then
                spl = Split(v, ",")
                v = spl(0)
            End If
        End If
        dict.Add c.Address, v
    End If

        If Len(v) = 0 Then
            v = "none"
        End If

'        If Len(v) = "" Then
'            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
        'copy cell value if it contains some string "holder" or "cutting tool"
        If InStr(c.Value, sHeader) <> 0 Then
            Set rv = c
            Exit For
        End If
    Next c
    Set HeaderCell = rv
End Function

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

The first picture shows what the code I currently have does. It prints NO HOLDER PRESENT! when there is a file that has nothing present in the HOLDER column; and when there are a few holders present but some blank spaces, it will print out the blank cells. The second one is when I implement .Find. It simply prints HOLDER where NO HOLDER PRESENT! should be and no longer includes spaces for blank cells.

enter image description here

Answer 1

解决方案： 需要更改用于查找标题下的值的函数

'(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
    Dim 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

VBA - .find printing wrong value

1 个答案: