大家帮忙看下我这个表的代码哪里错了

yhlbfsn

大神，救救我吧。附件里面第一张是数据源，我想按照部门把相应部门的数据复制到相应部门名称下面的工作表里，如果没有这个部门的工作表就新建个工作表并以部门为名称，再将数据复制到新建的对应工作表里，如果分表里有数据，新复制进去的数据会复制在下面的空白行，而不会覆盖掉原来的数据。我写的代码总是不行，还请各位大神帮我修改下，谢谢了！

小菜MM

1. Sub test()
   
2. '功能： 把部分拆分到各对应名称工作表，没有则新建。新纪录会追加到结尾，但不会检测重名记录！
   
3. '部门需放到第三列，部门无需排序。 所以运行效率会差些。可追加进度条改善交互。
   
4. '没有编写表头标题行，选工作组粘贴一下吧。
   
5. 
   
6. Dim arr() As Variant
   
7. Dim lngMaxRow As Long
   
8. Dim lngMaxCol As Long
   
9. 
   
10. Worksheets("Sheet1").Activate
    
11. lngMaxRow = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
    
12. lngMaxCol = Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
    
13. arr = Range(Cells(2, 1), Cells(lngMaxRow, lngMaxCol)).Value
    
14. 
    
15. Dim i As Long, j As Long
    
16. Dim shtWorksheet As Worksheet
    
17. Dim blnFind As Boolean
    
18. blnFind = False
    
19. 
    
20. For i = 1 To UBound(arr, 1)
    
21.     For Each shtWorksheet In Worksheets
    
22.         If shtWorksheet.Name = arr(i, 3) Then blnFind = True: Exit For
    
23.     Next shtWorksheet
    
24.     If blnFind = True Then
    
25.         shtWorksheet.Activate
    
26.         lngMaxRow = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
    
27.         For j = 1 To UBound(arr, 2)
    
28.             Cells(lngMaxRow + 1, j) = arr(i, j)
    
29.         Next j
    
30.     Else
    
31.         Worksheets.Add after:=Worksheets(Sheets.Count)
    
32.         ActiveSheet.Name = arr(i, 3)
    
33.         lngMaxRow = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
    
34.         For j = 1 To UBound(arr, 2)
    
35.             Cells(lngMaxRow + 1, j) = arr(i, j)
    
36.         Next j
    
37.     End If
    
38.     blnFind = False
    
39. Next i
    
40. 
    
41. End Sub
    

复制代码

小菜MM

Option Base 1

声明这句更合理点。