[已解决]求助,修改宏

新会甜橙

核对不了工作表的名称
同一文件夹内数据工作薄退信工作表的B列和明细工作薄的各工作表名称核对,退信工作表D列和明细工作薄各工作表的D列核对,相符时将退信工作表F、G单元格填入到明细工作薄同名工作表B、A单元格。(80多个表)

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-1 10:17

1. Sub 替换记录()
   
2.     'Dim app As Excel.Application
   
3.     'Set app = Excel.Application
   
4.     Dim dworkbook$
   
5.     dworkbook = "\明细.xls"
   
6.     '检测当前文件夹是否存在明细.xls
   
7.     dworkbook = Dir(ThisWorkbook.Path & dworkbook, vbNormal)
   
8.     If Len(dworkbook) = 0 Then MsgBox "当前文件夹下无 " & dworkbook: Exit Sub
   
9.    
   
10.     Dim wb As Workbook
    
11.     '读取数据
    
12.     Dim arr, irow&
    
13.     irow = Range("b" & Rows.Count).End(xlUp).Row()
    
14.     If irow = 1 Then Exit Sub
    
15.     arr = Range("a1").CurrentRegion
    
16.    
    
17.     '安全设定
    
18.     Dim secAutomation As MsoAutomationSecurity
    
19.     secAutomation = Application.AutomationSecurity
    
20.     Application.AutomationSecurity = msoAutomationSecurityForceDisable
    
21.    
    
22.     '关闭屏幕刷新
    
23.     Application.ScreenUpdating = False
    
24.     'set wb= workbooks.Open thisworkbo
    
25.     On Error Resume Next
    
26.     Set wb = Workbooks(dworkbook)
    
27.     If Err.Number <> 0 Then
    
28.    
    
29.         Set wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & dworkbook)
    
30.         If Err.Number <> 0 Then
    
31.             MsgBox dworkbook & "打开失败"
    
32.             Err.Clear
    
33.             Exit Sub
    
34.         End If
    
35.     End If
    
36.     wb.Activate
    
37.    
    
38.     Dim shtname$
    
39.     For i = LBound(arr) + 1 To UBound(arr)
    
40.         'On Error Resume Next
    
41.         shtname = Right(arr(i, 2), Len(arr(i, 2)) - 2)
    
42.         With Worksheets(shtname)
    
43.             If Err.Number <> 0 Then
    
44.                 MsgBox "读取 " & arr(i, 2) & " 工作表出错"
    
45.                 Err.Clear
    
46.             Else
    
47.                 irow = .Range("e:e").Find(arr(i, 5), LookIn:=xlValues, LookAt:=xlWhole).Row
    
48.                 If Err.Number <> 0 Then
    
49.                     MsgBox arr(i, 5) & " 在 工作表 " & arr(i, 2) & " 中无匹配记录"
    
50.                     Err.Clear
    
51.                 Else
    
52.                     .Cells(irow, "b") = arr(i, 6)
    
53.                     .Cells(irow, "a") = arr(i, 7)
    
54.                 End If
    
55.             End If
    
56.         End With
    
57.     Next
    
58.    
    
59.     Application.AutomationSecurity = secAutomation
    
60.     Application.ScreenUpdating = True
    
61.    
    
62.     wb.Save
    
63. End Sub

复制代码

根据楼主改过的数据写的。对了，数据的D列与明细的D列，因为逗号加入的位置不同，所以匹配的时候用的E列做比对的。
有些数据更新不成功。
另外，分行的名字一定要写准确了，你把江门都省去，这还好点，但后面有个营业部的最好还是不要省去，该一一对应的就一一对应，虽然用代码也能解决，但是如果数据在录入的时候做规范了，对于写代码是非常有益的。

跳转到最佳答案楼层

hwc2ycy

上次跟你说了，超长的数据加'号的，还没改习惯啊

hwc2ycy

你把数据改了，我就帮你写代码，

新会甜橙

hwc2ycy 发表于 2012-11-29 22:54
你把数据改了，我就帮你写代码，

谢老师批评,加,号有什么作用,想不明白?
重上附件部是否合要求

hwc2ycy

加了'号，数据读进数组，再写回单元各不会丢数据，否则后面几位数据全为0了。

新会甜橙

hwc2ycy 发表于 2012-11-29 23:22
加了'号，数据读进数组，再写回单元各不会丢数据，否则后面几位数据全为0了。

如果实际上我的数据是19位或20位,无,号有影响吗?数据量大系统导出的.

新会甜橙

hwc2ycy 发表于 2012-11-29 22:54
你把数据改了，我就帮你写代码，

期待老师的作品出现

新会甜橙

新会甜橙 发表于 2012-11-30 23:35
期待老师的作品出现

老师已重上附件,看看附合要求吗?

hwc2ycy

新会甜橙 发表于 2012-11-30 23:48
老师已重上附件,看看附合要求吗?

我试试，

hwc2ycy

1. Sub 替换记录()
   
2.     'Dim app As Excel.Application
   
3.     'Set app = Excel.Application
   
4.     Dim dworkbook$
   
5.     dworkbook = "\明细.xls"
   
6.     '检测当前文件夹是否存在明细.xls
   
7.     dworkbook = Dir(ThisWorkbook.Path & dworkbook, vbNormal)
   
8.     If Len(dworkbook) = 0 Then MsgBox "当前文件夹下无 " & dworkbook: Exit Sub
   
9.    
   
10.     Dim wb As Workbook
    
11.     '读取数据
    
12.     Dim arr, irow&
    
13.     irow = Range("b" & Rows.Count).End(xlUp).Row()
    
14.     If irow = 1 Then Exit Sub
    
15.     arr = Range("a1").CurrentRegion
    
16.    
    
17.     '安全设定
    
18.     Dim secAutomation As MsoAutomationSecurity
    
19.     secAutomation = Application.AutomationSecurity
    
20.     Application.AutomationSecurity = msoAutomationSecurityForceDisable
    
21.    
    
22.     '关闭屏幕刷新
    
23.     Application.ScreenUpdating = False
    
24.     'set wb= workbooks.Open thisworkbo
    
25.     On Error Resume Next
    
26.     Set wb = Workbooks(dworkbook)
    
27.     If Err.Number <> 0 Then
    
28.    
    
29.         Set wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & dworkbook)
    
30.         If Err.Number <> 0 Then
    
31.             MsgBox dworkbook & "打开失败"
    
32.             Err.Clear
    
33.             Exit Sub
    
34.         End If
    
35.     End If
    
36.     wb.Activate
    
37.    
    
38.     Dim shtname$
    
39.     For i = LBound(arr) + 1 To UBound(arr)
    
40.         'On Error Resume Next
    
41.         shtname = Right(arr(i, 2), Len(arr(i, 2)) - 2)
    
42.         With Worksheets(shtname)
    
43.             If Err.Number <> 0 Then
    
44.                 MsgBox "读取 " & arr(i, 2) & " 工作表出错"
    
45.                 Err.Clear
    
46.             Else
    
47.                 irow = .Range("e:e").Find(arr(i, 5), LookIn:=xlValues, LookAt:=xlWhole).Row
    
48.                 If Err.Number <> 0 Then
    
49.                     MsgBox arr(i, 5) & " 在 工作表 " & arr(i, 2) & " 中无匹配记录"
    
50.                     Err.Clear
    
51.                 Else
    
52.                     .Cells(irow, "b") = arr(i, 6)
    
53.                     .Cells(irow, "a") = arr(i, 7)
    
54.                 End If
    
55.             End If
    
56.         End With
    
57.     Next
    
58.    
    
59.     Application.AutomationSecurity = secAutomation
    
60.     Application.ScreenUpdating = True
    
61.    
    
62.     wb.Save
    
63. End Sub

复制代码

根据楼主改过的数据写的。对了，数据的D列与明细的D列，因为逗号加入的位置不同，所以匹配的时候用的E列做比对的。
有些数据更新不成功。
另外，分行的名字一定要写准确了，你把江门都省去，这还好点，但后面有个营业部的最好还是不要省去，该一一对应的就一一对应，虽然用代码也能解决，但是如果数据在录入的时候做规范了，对于写代码是非常有益的。