Question

这是一个较大程序的子程序（如果需要，我可以复制并粘贴整个程序）。我得到了一个未知的运行时错误，我不能为我的生活找出原因。我花了几个小时沮丧，并决定来找你们帮忙！

快速编辑：我试图找到特定的列标题，然后选择整个列（减去标题）作为范围。

Sub YearSmash(MyString)
    With objSheetSrc
        Set FoundCell = .Range("A1:BZ1").Find(MyString, , , 1)
        If FoundCell Is Nothing Then
            Exit Sub
        End If

        MsgBox(FoundCell)

        Set rng1 = .Range(FoundCell.Offset(1), FoundCell.Offset(1).End(xlDown))

        MsgBox(rng1)
    End With
End Sub

以下行发生错误：

Set rng1 = .Range(FoundCell.Offset(1), FoundCell.Offset(1).End(xlDown))

有什么想法吗？此外，我试图提取的数据中没有无效值，错误或NULL值。

谢谢，

安德鲁

编辑以完整显示代码：

Const xlFilterCopy = 2
strPathSrc = "C:\test" ' Source files folder
strMaskSrc = "*.xlsx" ' Source files filter mask

dtmDate = Date
strMonth = Month(Date)
strDay = Day(Date)
strYear = Right(Year(Date), 2)
strFileName = "C:\test\Results\" & strMonth & "-" & StrDay & "-" & strYear & " Results.xlsx"
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False

Set objWorkbook = objExcel.Workbooks.Add()
objWorkbook.SaveAs(strFileName)
objExcel.Quit

'strPathDst = "C:\test\Results\Results.xlsx" ' Destination file
strPathDst = strFileName

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
Set objWorkBookDst = objExcel.Workbooks.Open(strPathDst)
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.NameSpace(strPathSrc)
Set objItems = objFolder.Items()
objItems.Filter 64 + 128, strMaskSrc
objExcel.DisplayAlerts = False
x = 1
y = 1
MsgBox("Working")
For Each objItem In objItems
    Set objWorkBookSrc = objExcel.Workbooks.Open(objItem.Path)
    Set objSheetSrc = objWorkBookSrc.Sheets(1)
    Set objSheetDst = objWorkBookDst.Sheets(1)
    For Each Cell In objSheetSrc.Range("A1:Z15")
        If Cell.MergeCells = True Then
            Set objRange = Cell.EntireRow
            objRange.Delete
        End If
    Next

    'Set FoundCell = objSheetSrc.Range("A1:BZ1").Find("Device", , , 1)

    'For Each Cell In objSheetSrc.Range(FoundCell.Offset(1,0), objSheetSrc.Cells(objSheetSrc.Rows.Count, FoundCell.Column).End(-4162)).Cells
        'If Cell.Value <> "*MSP430*" Then
        '   Cell.EntireRow.Delete
        'End If
    'Next

    Set objSheetDst = objWorkBookDst.Sheets(1)

    Call FindCell("Sales Region")
    Call FindCell("Sales Area")
    Call FindCell("TSR Role")
    Call FindCell("My Account")
    Call FindCell("Account Class")
    Call FindCell("Project Name")
    Call FindCell("Device")
    Call FindCell("AUP")
    Call FindCell("Qty Per Board")
    Call FindCell("Device Status")
    Call FindCell("Project Status")
    Call FindCell("Project Kickoff")
    Call FindCell("Market")
    Call FindCell("SBE")
    Call FindCell("SBE-1")
    Call FindCell("SBE-2")
    Call FindCell("2013 Q1")
    Call FindCell("2013 Q2")
    Call FindCell("2013 Q3")
    Call FindCell("2013 Q4")
    Call FindCell("2014 Q1")
    Call FindCell("2014 Q2")
    Call FindCell("2014 Q3")
    Call FindCell("2014 Q4")
    Call FindCell("2015 Q1")
    Call FindCell("2015 Q2")
    Call FindCell("2015 Q3")
    Call FindCell("2015 Q4")
    Call FindCell("2016")
    Call YearSmash("2016 Q1")
    Call FindCell("2016 Q1")
    Call FindCell("2017")
    Call FindCell("2018")

    objWorkBookSrc.Close
Next

objExcel.Visible = True

Sub FindCell(MyString)
    Do While objSheetDst.Cells(x, y).Value <> ""
        y = y + 1
    Loop

    If MyString = "Sales Region" And y > 2 Then
        y = 1
        Do While objSheetDst.Cells(x, y).Value <> ""
            x = x + 1
        Loop
    End If

    Set FoundCell = objSheetSrc.Range("A1:BZ1").Find(MyString, , , 1)
    If FoundCell Is Nothing Then
        Exit Sub
    End If

    Set objRangeSrc = FoundCell.EntireColumn
    objRangeSrc.AdvancedFilter xlFilterCopy, , objSheetDst.Cells(x, y), False
End Sub

Sub YearSmash(MyString)
    With objSheetSrc
        Set FoundCell = .Range("A1:BZ1").Find(MyString, , , 1)
        If FoundCell Is Nothing Then Exit Sub

        Set lRow = .Cells(.Rows.Count, FoundCell.Column).End(xlUp).Row

        Set rng1 = .Range(.Cells(FoundCell.Row + 1, FoundCell.Column), .Cells(lRow, FoundCell.Column))

        MsgBox rng1.Address
    End With
End Sub

Answer 1

这是你在尝试的吗？

Sub YearSmash(MyString)
    Dim objSheetSrc As Worksheet
    Dim lRow As Long
    Dim FoundCell As Range, rng1 As Range
    Dim MyString As String

    '~~> Change as applicable
    Set objSheetSrc = ThisWorkbook.Sheets("Sheet1")

    With objSheetSrc
        Set FoundCell = .Range("A1:BZ1").Find(MyString, , , 1)

        If FoundCell Is Nothing Then Exit Sub

        '~~> Find the last row in that column
        lRow = .Cells(.Rows.Count, FoundCell.Column).End(xlUp).Row

        '~~> Construct your range from one cell offset
        Set rng1 = .Range(.Cells(FoundCell.Row + 1, FoundCell.Column), _
                          .Cells(lRow, FoundCell.Column))

        MsgBox rng1.Address
    End With
End Sub

从评论中跟进

我在vbscript中进行了测试，效果很好

Dim oXLApp, olXLWb, objSheetSrc
Dim MyString, lRow, FoundCell, rng1

Set oXLApp = CreateObject("Excel.Application")

oXLApp.Visible = True

'~~> Sample File
Set olXLWb = oXLApp.Workbooks.Open("C:\Sample.xlsx")

'~~> Change as applicable
Set objSheetSrc = olXLWb.Sheets("Sheet1")

'~~> Sample String
MyString = "Sid"

With objSheetSrc
    Set FoundCell = .Range("A1:BZ1").Find(MyString, , , 1)

    If Not FoundCell Is Nothing Then
        '~~> Find the last row in that column
        lRow = .Cells(.Rows.Count, FoundCell.Column).End(-4162).Row

        '~~> Construct your range from one cell offset
        Set rng1 = .Range(.Cells(FoundCell.Row + 1, FoundCell.Column), _
                          .Cells(lRow, FoundCell.Column))

        MsgBox rng1.Address
    End If
End With

设置范围时发生未知运行时错误

1 个答案: