CODEWITHSUNDEEP
vbaexcel
Taylor
Taylor

Reputation: 181

VBA - getting a value from a unique range

                Set hc5 = HeaderCell2(ws.Cells(ROW_HEADER, 1), "TOOLING DATA SHEET")
                If hc5 <> "" Then
                    hc5.Offset(, 1) = StartSht.Cells(Rows.count, hc4.Column).End(xlUp).Offset(1, 0)
                   Else
                   StartSht.Cells(i, 1) = 1

...

'find a header on a row: returns Nothing if not found
Function HeaderCell2(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 "tooling data sheet"
        If InStr(c.Value, sHeader) <> 0 Then
            Set rv = c
            Exit For
        End If
    Next c
    Set HeaderCell2 = rv
End Function

I have this as my code. I just put the else in there to see if the if statement was working which it is not since it prints out the 1. I'm not sure what I have set wrong with but the error says Object variable or with block variable not set. It is supposed to find the cell containing the words "TOOLING DATA SHEET", move one cell to the right, grab that information and output it to my StartSht called masterfile. Any help please? I've been stuck for hours

Here is the full code if you need it. (Ugly commented out section are my attempts at fixing it)

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 FinalRow As Long
    Dim f As String
    Dim dict As Object
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, hc5 As Range, d As Range
    Dim c 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")

    '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
                    '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)
                    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 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)
                    End If
                    'End If
                Else
                    'header not found on source worksheet
                End If

'(4.2)
'                find TDS on the source sheet
                Set hc5 = HeaderCell2(ws.Cells(ROW_HEADER, 1), "TOOLING DATA SHEET")
                If hc5 <> "" Then
                    hc5.Offset(, 1) = StartSht.Cells(Rows.count, hc4.Column).End(xlUp).Offset(1, 0)
                   Else
                   StartSht.Cells(i, 1) = 1
'                    Set d = StartSht.Cells(Rows.count, hc4.Column).End(xlUp).Offset(1, 0)
'                    d.Value = Application.Transpose(hc5)
'                    'StartSht.Cells(i, 1).Paste
''                    Set dict = GetValues(hc5.Offset(0, 1))
''                    'If InStr(ROW_HEADER, "HOLDER") <> "" Then
''                    If dict.count > 0 Then
''                        Set d = StartSht.Cells(Rows.count, hc4.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
                    End If
                'Else
'                    'header not found on source worksheet
                'End If


'(5)
            With WB
               'print TDS information
                For Each ws In .Worksheets
                        'print the file name to Column 1
                        StartSht.Cells(i, 4) = objFile.Name
                        'StartSht.Range(StartSht.Cells(i, 4), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 4)) = objFile.Name

'
'                        Set hc5 = HeaderCell2(ws.Cells(ROW_HEADER, 1), "TOOLING DATA SHEET")
                        'StartSht.Cells(Rows.count, hc5.Column).End(xlUp).Offset(1, 0) = hc5
'                        d.Offset(, 1) = StartSht.Cells(Rows.count, hc4.Column).End(xlUp).Offset(1, 0)
'                        'print TDS name from J1 cell to Column 4 (****change because we want header not cell)
                        With ws
'                            '.Range("J1").Copy StartSht.Cells(i, 4)
                            .Range("J1").Copy StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1))
''                            'StartSht.Cells(i, 4).Value2 = GetTDSName(ws, 1)
''                            'StartSht.Cells(i, 4).Paste
                        End With
                        i = GetLastRowInSheet(StartSht) + 1

'                    Set hc5 = HeaderCell2(ws.Cells(ROW_HEADER, 1), "TOOLING DATA SHEET (TDS):")
'                    If Not hc5 Is Nothing Then
'
'
'                            Set d = StartSht.Cells(Rows.count, hc4.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)
'                    Else
'                    'header not found on source worksheet
'                    End If





                'move to next file
                Next ws
'(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 Len(v) > 0 And Not dict.exists(v) 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

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

'(9.2)
'find a header on a row: returns Nothing if not found
Function HeaderCell2(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 "tooling data sheet"
        If InStr(c.Value, sHeader) <> 0 Then
            Set rv = c
            Exit For
        End If
    Next c
    Set HeaderCell2 = 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


Function GetTDSName(theWorksheet As Worksheet)
Dim ret
    With theWorksheet
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            ret = Range("J1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1).Row
        Else
            ret = 1
        End If
    End With
    GetTDSName = ret
End Function

EDIT: CURRENT CODE ATTEMPT It works to find the header and print out the cell to the right. But it will not skip over and print "" if the header is not found

With ws
    If Not Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1) 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)) = ""
    End If
End With

Upvotes: 0

Views: 228

Answers (1)

user4039065
user4039065

Reputation:

Dealing with a range that is not set means you are dealing with range is nothing and often necessitates bringing on error resume next into the code. Consider this 'passive' approach that doesn't break something just to check if it is there.

    Dim p As Long
    With ws
        If CBool(Application.CountIf(.Rows(ROW_HEADER), "TOOLING DATA SHEET")) Then
            p = Application.Match("TOOLING DATA SHEET", .Rows(ROW_HEADER), 0)
            .Cells(1, p + 1) = StartSht.Cells(Rows.Count, hc4.Column).End(xlUp).Offset(1, 0)
        Else
            StartSht.Cells(i, 1) = 1
        End If
    End With

While trying to MATCH something that isn't there will also throw an error, making sure that it is there with the passive COUNTIF first guarantees that no error will be thrown.

Upvotes: 2

Related Questions