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

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值。

感谢，

安德鲁

Editted在其整体显示代码：

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