【求助】把指定内容提取到新建的工作簿 - Excel/VBA论坛

已结贴√ 问题点数：20 回复次数：1

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

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行数据存到新的工作簿中，但提示要求对象错误，请问如何修改

搜索更多相关主题的帖子: Application　工作　指定　提取　 If　