【求助】 把指定内容提取到新建的工作簿

Sub 地质()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.Activate
Sheets("百合地质表").Activate
Sheets("百合地质表").Range("A3:A2500").Clear
Sheets("地质明细表").Range("A5:A2500").Copy Sheets("百合地质表").Range("A3")
Dim i, j, str, arr1, arr2, sht As Worksheet, wb   As Workbook
j = 3
arr1 = Sheets("百合地质表").Range("b1:r2")
For i = 4 To 2500
 If Cells(i, 2) <> 0 Then
  If Cells(i, 2) = 1 Then
    arr2 = ThisWorkbook.Sheets("百合地质表").Range(Cells(j, 2), Cells(i - 1, 12))
    str = ThisWorkbook.Sheets("百合地质表").Cells(i, 1)
    sFileName = ThisWorkbook.Path & "\" & str & "地质.CSV"  
    Set wb = Workbooks.Add
    Set sht = wb.Worksheets(1)
      arr1.Copy sht.Range("A1")
      arr2.Copy sht.Range("A3")
     wb.SaveAs sFileName
     wb.Close
     j = i
  End If
  End If
  Next  
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True  
End Sub


想提取每一个编号对应的B:R行数据存到新的工作簿中，但提示 要求对象错误，请问如何修改