[已解决]VBA代码运行错误求助

网络人

里面导入数据的代码我修改了一下，就运行报错，帮忙看下是错在那里，按照F列与另外工作薄E列对应名称的A列数据引用到N列的VBA代码修正。具体见附件

最佳答案

月排行榜 / 总排行榜

chart888

2017-6-3 08:29

1. Private Sub CommandButton1_Click()
   
2. 
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. 
   
6. Dim WB As Workbook
   
7. Dim F, E
   
8. Dim arr
   
9. 
   
10. F = False
    
11. For Each E In Workbooks
    
12.     If E.Name = "2017年新订单进度表.xls" Then
    
13.         F = True
    
14.         If MsgBox("请关闭当前操作界面中已经打开的【2017年新订单进度表】后再操作！", 32 + 256) = 6 Then
    
15.             Exit Sub
    
16.         End If
    
17.     End If
    
18. Next
    
19. If F = False Then
    
20.     Set fso = CreateObject("scripting.filesystemobject")
    
21.     Set fld = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, 0)
    
22.     If fld Is Nothing Then End
    
23.     fp = fld.Self.Path
    
24.     Workbooks.Open Filename:=fp & "" & "2017年新订单进度表.xls"  '读入
    
25.     arr = Sheets("在制（未完成）").UsedRange
    
26.     ActiveWorkbook.Close savechanges:=False
    
27.     lastrow = Cells(Rows.Count, 6).End(3).Row            '当前工作表
    
28.     On Error Resume Next
    
29.     For n = 4 To lastrow
    
30.         For i = 2 To UBound(arr)
    
31.             If ActiveSheet.Cells(n, 6) = arr(i, 5) Then  '前面是当前工作表，后面是数据源工作薄
    
32.                 ActiveSheet.Cells(n, 14) = arr(i, 1)
    
33.             
    
34.             End If
    
35.         Next
    
36.     Next
    
37. End If
    
38. 
    
39. Application.ScreenUpdating = True
    
40. Application.DisplayAlerts = True
    
41. End Sub
    

复制代码

跳转到最佳答案楼层

chart888

看你的代码好像问题不少
你把要求写出来
别人才能帮你

安全网

chart888 发表于 2017-6-2 16:36
看你的代码好像问题不少
你把要求写出来
别人才能帮你

就是按照对应的名称引用另外工作薄的数据

网络人

我需要的是黄色区域的名称对应引用另外工作薄对应名称的日期数据

网络人

chart888 发表于 2017-6-2 16:36
看你的代码好像问题不少
你把要求写出来
别人才能帮你

按照F列与另外工作薄E列对应名称的A列数据引用到N列的VBA代码修正，附件已经修改

chart888

1. 
   
2. Private Sub CommandButton1_Click()
   
3. Application.ScreenUpdating = False
   
4. Dim WB As Workbook
   
5. Dim F, E
   
6.     F = False
   
7.     For Each E In Workbooks
   
8. If E.Name = "2017年新订单进度表.xls" Then
   
9.        F = True
   
10.            If MsgBox("请关闭当前操作界面中已经打开的【2017年新订单进度表】后再操作！", 32 + 256) = 6 Then
    
11.        Exit Sub
    
12. End If
    
13. End If
    
14.     Next E
    
15. If F = False Then
    
16.    
    
17.     Set fso = CreateObject("scripting.filesystemobject")
    
18.     Set fld = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, 0)
    
19.     If fld Is Nothing Then End
    
20.    
    
21.     fp = fld.Self.Path
    
22. Workbooks.Open Filename:=fp & "\2017年新订单进度表.xls"  '读入
    
23. arr = Sheets("在制（未完成）").UsedRange
    
24. ActiveWorkbook.Close savechanges:=False
    
25. lastrow = Cells(Rows.Count, 6).End(3).Row            '当前工作表
    
26. For n = 4 To lastrow
    
27.     For i = 2 To UBound(arr)
    
28.         If Cells(n, 6) = arr(i, 5) Then  '前面是当前工作表，后面是数据源工作薄
    
29.             Cells(n, "n") = arr(i, 1)
    
30.         End If
    
31.     Next i
    
32. Next n
    
33. End If
    
34. End Sub
    

复制代码

网络人

chart888 发表于 2017-6-2 19:07

没有改代码吗？还是出现图片这样的错误，不知道是什么原因

网络人

请高手帮忙这个错误的原因在哪里？我只是改了下工作表名称

chart888

1. Private Sub CommandButton1_Click()
   
2. 
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. 
   
6. Dim WB As Workbook
   
7. Dim F, E
   
8. Dim arr
   
9. 
   
10. F = False
    
11. For Each E In Workbooks
    
12.     If E.Name = "2017年新订单进度表.xls" Then
    
13.         F = True
    
14.         If MsgBox("请关闭当前操作界面中已经打开的【2017年新订单进度表】后再操作！", 32 + 256) = 6 Then
    
15.             Exit Sub
    
16.         End If
    
17.     End If
    
18. Next
    
19. If F = False Then
    
20.     Set fso = CreateObject("scripting.filesystemobject")
    
21.     Set fld = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, 0)
    
22.     If fld Is Nothing Then End
    
23.     fp = fld.Self.Path
    
24.     Workbooks.Open Filename:=fp & "" & "2017年新订单进度表.xls"  '读入
    
25.     arr = Sheets("在制（未完成）").UsedRange
    
26.     ActiveWorkbook.Close savechanges:=False
    
27.     lastrow = Cells(Rows.Count, 6).End(3).Row            '当前工作表
    
28.     On Error Resume Next
    
29.     For n = 4 To lastrow
    
30.         For i = 2 To UBound(arr)
    
31.             If ActiveSheet.Cells(n, 6) = arr(i, 5) Then  '前面是当前工作表，后面是数据源工作薄
    
32.                 ActiveSheet.Cells(n, 14) = arr(i, 1)
    
33.             
    
34.             End If
    
35.         Next
    
36.     Next
    
37. End If
    
38. 
    
39. Application.ScreenUpdating = True
    
40. Application.DisplayAlerts = True
    
41. End Sub
    

复制代码

网络人

chart888 发表于 2017-6-3 08:29

还是错误。arr(i, 5)出现的ERROR2023的错误