[已解决]修改代码增加导入信息问题

sdwffw

book1.zip (247.39 KB, 下载次数: 4)

2013-5-24 15:21 上传

点击文件名下载附件 在多位论坛老师的指导下，做了一个程序，其中有调入数据功能，现在想请老师做一点修改，在调出的数据中再加一项信息，详见附件。非常感谢！！系统管理员密码：858999

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-5-24 16:44

1. Sub 调入数据()
   
2.     Application.ScreenUpdating = True
   
3.     Range("a4:e4").ClearContents
   
4.     Range("b6").ClearContents
   
5.     Range("e6:j6").ClearContents
   
6.     Range("b7:e7").ClearContents
   
7.     Range("c15:m15").ClearContents
   
8.     '   On Error GoTo 10
   
9.     NAM = Application.GetOpenFilename(FileFilter:="源文档(*.xls),*.xls", Title:="请选取文件导入")
   
10.     If NAM = False Then Exit Sub
    
11.     Workbooks.Open (NAM)
    
12.     With ActiveWorkbook.Sheets(1)
    
13.         w = .Range("B65536").End(3).Row
    
14.         i = 1
    
15.         Set x = .Range("B5:B" & w).Find("序号")
    
16.         If Not x Is Nothing Then firstAddress = x.Address
    
17.         Do
    
18.             n = -1
    
19.             Do Until (x.Offset(n, 0) = "申请人名称" Or x.Offset(n, 0) = "企业名称")
    
20.                 ReDim Preserve arr(1 To 4, 1 To i)
    
21.                 arr(1, i) = x.Offset(n, 0)
    
22.                 arr(2, i) = x.Offset(n, 1)
    
23.                 arr(4, i) = x.Offset(n, 11)
    
24.                 i = i + 1
    
25.                 n = n - 1
    
26.             Loop
    
27.             Set x = .Range("B5:B" & w).FindNext(x)
    
28.         Loop While Not x Is Nothing And x.Address <> firstAddress
    
29.     End With
    
30.     ActiveWorkbook.Close
    
31. 
    
32.     BRR = ThisWorkbook.Sheets(3).Range("A2:B" & ThisWorkbook.Sheets(3).Range("A65536").End(3).Row)
    
33.     For i = 1 To UBound(arr, 2)
    
34.         For j = 1 To UBound(BRR)
    
35.             If InStrRev(arr(2, i), BRR(j, 2)) Then
    
36.                 arr(2, i) = BRR(j, 2)
    
37.                 arr(3, i) = BRR(j, 1)
    
38.                 Exit For
    
39.             End If
    
40.         Next
    
41.     Next
    
42. 
    
43.     选择.Show 0
    
44.     Exit Sub
    
45. 10  MsgBox "请检查源文件是否都正确！"
    
46.     Application.ScreenUpdating = True
    
47. End Sub

复制代码

调入数据的过程改了下，先读取了150的观察员数据，还没有做检验。

跳转到最佳答案楼层

sdwffw

不知为何，传了3个，最后一个是我想传的。

hwc2ycy

观察员数据是M列的数据不？

sdwffw

是的，想固定在M列。谢谢老师。

hwc2ycy

1. Sub 调入数据()
   
2.     Application.ScreenUpdating = True
   
3.     Range("a4:e4").ClearContents
   
4.     Range("b6").ClearContents
   
5.     Range("e6:j6").ClearContents
   
6.     Range("b7:e7").ClearContents
   
7.     Range("c15:m15").ClearContents
   
8.     '   On Error GoTo 10
   
9.     NAM = Application.GetOpenFilename(FileFilter:="源文档(*.xls),*.xls", Title:="请选取文件导入")
   
10.     If NAM = False Then Exit Sub
    
11.     Workbooks.Open (NAM)
    
12.     With ActiveWorkbook.Sheets(1)
    
13.         w = .Range("B65536").End(3).Row
    
14.         i = 1
    
15.         Set x = .Range("B5:B" & w).Find("序号")
    
16.         If Not x Is Nothing Then firstAddress = x.Address
    
17.         Do
    
18.             n = -1
    
19.             Do Until (x.Offset(n, 0) = "申请人名称" Or x.Offset(n, 0) = "企业名称")
    
20.                 ReDim Preserve arr(1 To 4, 1 To i)
    
21.                 arr(1, i) = x.Offset(n, 0)
    
22.                 arr(2, i) = x.Offset(n, 1)
    
23.                 arr(4, i) = x.Offset(n, 11)
    
24.                 i = i + 1
    
25.                 n = n - 1
    
26.             Loop
    
27.             Set x = .Range("B5:B" & w).FindNext(x)
    
28.         Loop While Not x Is Nothing And x.Address <> firstAddress
    
29.     End With
    
30.     ActiveWorkbook.Close
    
31. 
    
32.     BRR = ThisWorkbook.Sheets(3).Range("A2:B" & ThisWorkbook.Sheets(3).Range("A65536").End(3).Row)
    
33.     For i = 1 To UBound(arr, 2)
    
34.         For j = 1 To UBound(BRR)
    
35.             If InStrRev(arr(2, i), BRR(j, 2)) Then
    
36.                 arr(2, i) = BRR(j, 2)
    
37.                 arr(3, i) = BRR(j, 1)
    
38.                 Exit For
    
39.             End If
    
40.         Next
    
41.     Next
    
42. 
    
43.     选择.Show 0
    
44.     Exit Sub
    
45. 10  MsgBox "请检查源文件是否都正确！"
    
46.     Application.ScreenUpdating = True
    
47. End Sub

复制代码

调入数据的过程改了下，先读取了150的观察员数据，还没有做检验。

sdwffw

谢谢老师。我把代码复制运行后，弹出的“选择打印”表中没把观察员信息调入。

sdwffw

好像是这句语句   arr(4, i) = x.Offset(n, 11) 没起作用。

sdwffw

试着对应修改了关联的两处地方，实现了观察员信息的调入，感谢老师指导。我在原贴提出的第二个问题：“b6单元格调入的观察员，如果“观察员维护”表中已有对应数据，则直接调入；如果“观察员维护”表中无数据，则提示“库中无该人员”，不调入”请老师帮助加段代码，感谢。

hwc2ycy

sdwffw 发表于 2013-5-24 17:17
谢谢老师。我把代码复制运行后，弹出的“选择打印”表中没把观察员信息调入。

忘了，窗体的代码没有发给你，窗体的INIT过程里有代码是把ARR的数据加载到LISTVIEW的，那里也要加一行。

1. ITM.SubItems(3) = arr(4, i)

复制代码

调入数据过程里的
ActiveWorkbook.Close改为

1. ActiveWorkbook.Close False

复制代码

这样不会有提示是否保存之类的，比较好。

hwc2ycy

sdwffw 发表于 2013-5-25 05:12
试着对应修改了关联的两处地方，实现了观察员信息的调入，感谢老师指导。我在原贴提出的第二个问题：“b6单 ...

你说的B6单元格是哪个工作簿哪个工作表中的？

按钮所在的通知工作表，貌似是B7吧。