Question

                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

我将此作为我的代码。我只是将else放在那里，看看if语句是否正常工作，因为它打印出1.我不确定我设置的错误但是错误说对象变量或未设置块变量。它应该找到包含单词＆＃34; TOOLING DATA SHEET＆＃34;的单元格，向右移动一个单元格，获取该信息并将其输出到名为masterfile的StartSht。有什么帮助吗？我被困了几个小时

如果您需要，这是完整的代码。（丑陋的评论部分是我试图修复它）

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

编辑：当前代码尝试 它可以找到标题并将单元格打印到右侧。但它不会跳过并打印＆＃34;＆＃34;如果找不到标题

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

Answer 1

处理未设置的范围意味着您正在处理范围是什么并且经常需要将on error resume next带入代码中。考虑一下这个被动的＆＃39;不会破坏某些东西只是为了检查它是否存在的方法。

    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

尝试匹配某些不存在的东西时，也会抛出错误，使确定它与被动COUNTIF一起保证不会抛出任何错误。

VBA - 从唯一范围获取值

1 个答案: