設置範圍時發生未知運行時錯誤

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