将一个excel表上的内容筛选后，粘贴到多个EXCEL表格中，运行总是出现空白表是怎么回事？

Question

1. 将一个excel表上的内容筛选后，粘贴到多个EXCEL表格中，运行总是出现“运行时错误，下标越界”？
2. 要实现的功能是将不同成本中心的固定资产筛选出来，把内容放到一个个excel表格中。

1. Sub 拆分()
   Application.ScreenUpdating = False
   mc = "Fixed Asset List of 固定资产明细表"
   Set Rng = ThisWorkbook.Sheets("数据源").Rows(1)
   arr = ThisWorkbook.Sheets("数据源").[a1].CurrentRegion
   ReDim brr(1 To UBound(arr), 1 To UBound(arr, 13))
   ReDim crr(1 To UBound(arr), 1 To UBound(arr, 13))
   ReDim drr(1 To UBound(arr), 1 To UBound(arr, 13))
   ReDim Err(1 To UBound(arr), 1 To UBound(arr, 13))
   ReDim frr(1 To UBound(arr), 1 To UBound(arr, 13))
   For i = 2 To UBound(arr)
   If Trim(arr(i, 7)) = "10401" Then
   n = n + 1
   For j = 1 To UBound(arr, 13)
   brr(n, j) = arr(i, j)
   Next j
   End If
   Next i

   For i = 2 To UBound(arr)
   If Trim(arr(i, 7)) = "20506" Then
   m = m + 1
   For j = 1 To UBound(arr, 13)
   crr(m, j) = arr(i, j)
   Next j
   End If
   Next i

   For i = 2 To UBound(arr)
   If Trim(arr(i, 7)) = "20701" Then
   p = p + 1
   For j = 1 To UBound(arr, 13)
   crr(p, j) = arr(i, j)
   Next j
   End If
   Next i

   For i = 2 To UBound(arr)
   If Trim(arr(i, 7)) = "20705" Then
   q = q + 1
   For j = 1 To UBound(arr, 13)
   crr(q, j) = arr(i, j)
   Next j
   End If
   Next i
   For i = 2 To UBound(arr)
   If Trim(arr(i, 7)) = "20601" Then
   r = r + 1
   For j = 1 To UBound(arr, 13)
   crr(r, j) = arr(i, j)
   Next j
   End If
   Next i

   Application.SheetsInNewWorkbook = 1
   If n <> "" Then
   Set wb = Workbooks.Add
   With wb.Worksheets(1)
   Rng.Copy .[a1]
   .[a2].Resize(n, UBound(brr, 13)) = brr
   End With
   wb.SaveAs Filename:=ThisWorkbook.Path & "\" & "10401_" & mc
   wb.Close
   End If

   If m <> "" Then
   Set wb = Workbooks.Add
   With wb.Worksheets(1)
   Rng.Copy .[a1]
   .[a2].Resize(m, UBound(crr, 13)) = crr
   End With
   wb.SaveAs Filename:=ThisWorkbook.Path & "\" & "20506" & mc
   wb.Close
   End If
   If m <> "" Then
   Set wb = Workbooks.Add
   With wb.Worksheets(1)
   Rng.Copy .[a1]
   .[a2].Resize(m, UBound(drr, 13)) = drr
   End With
   wb.SaveAs Filename:=ThisWorkbook.Path & "\" & "20701" & mc
   wb.Close
   End If
   If m <> "" Then
   Set wb = Workbooks.Add
   With wb.Worksheets(1)
   Rng.Copy .[a1]
   .[a2].Resize(m, UBound(Err, 13)) = Err
   End With
   wb.SaveAs Filename:=ThisWorkbook.Path & "\" & "20705" & mc
   wb.Close
   End If
   If m <> "" Then
   Set wb = Workbooks.Add
   With wb.Worksheets(1)
   Rng.Copy .[a1]
   .[a2].Resize(m, UBound(frr, 13)) = frr
   End With
   wb.SaveAs Filename:=ThisWorkbook.Path & "\" & "20601" & mc
   wb.Close
   End If
   Application.ScreenUpdating = True
   MsgBox "ok!"
   End Sub

4.这是从网上找的答案，被我修改过的结果。
5. 下标越界截图

Answer 1

https://jingyan.baidu.com/article/37bce2be43589f1002f3a2b2.html