[已解决]求助,修改宏

hwc2ycy

1. Sub 数据3()
   
2.     Dim arr
   
3.     Dim iRow&, i&, wbzb$
   
4.    
   
5.     '读取总表源数据
   
6.     wbzb = "总表"
   
7.     ThisWorkbook.Activate
   
8.     With Worksheets(wbzb)
   
9.         If Len(.[a3]) = 0 Then Exit Sub
   
10.         '高级筛选,去除重复值
    
11.         .Range("a3").CurrentRegion.AdvancedFilter xlFilterInPlace, , , True
    
12.         iRow = .Range("c" & Rows.Count).End(xlUp).Row
    
13.         If iRow <= 3 Then Exit Sub  '最后一行数据行低于第3行位置就退出
    
14.         arr = .Range("a3:i" & iRow)
    
15.     End With
    
16.    
    
17.     'arr2数组存储数据
    
18.     Dim dic As Object, arr2(), k&, j&
    
19.     '数据列对应关系，arrZos源列号，arrMpos目标列号
    
20.     Dim arrZPos, arrMPos, arrTemp
    
21.     arrZPos = Array(4, 5, 6, 7, 8, 9)
    
22.     arrMPos = Array(1, 2, 3, 4, 5, 10)
    
23.    
    
24.     '以支行网点名字存入字典
    
25.     Set dic = CreateObject("Scripting.dictionary")
    
26.     For i = 2 To UBound(arr)
    
27.         If Not dic.exists(arr(i, 3)) Then
    
28.             ReDim arr2(1 To 10, 1 To 1)
    
29.             For j = LBound(arrZPos) To UBound(arrZPos)
    
30.                 arr2(arrMPos(j), 1) = arr(i, arrZPos(j))
    
31.             Next
    
32.             dic(arr(i, 3)) = Array(1, arr2) '0为存入个数，1为数组
    
33.         Else
    
34.             arrTemp = dic(arr(i, 3))
    
35.             k = arrTemp(0) + 1
    
36.             arr2 = arrTemp(1)
    
37.             ReDim Preserve arr2(1 To 10, 1 To k)
    
38.             For j = LBound(arrZPos) To UBound(arrZPos)
    
39.                 arr2(arrMPos(j), k) = arr(i, arrZPos(j))
    
40.             Next
    
41.             dic(arr(i, 3)) = Array(k, arr2)
    
42.         End If
    
43.     Next
    
44. 
    
45.     On Error Resume Next
    
46.     Dim wb As Workbook
    
47.     Dim wbname$, Slash$
    
48.     wbname = "明细.xls"
    
49.     Slash = Application.PathSeparator
    
50. 
    
51.     Dim secAutomation As MsoAutomationSecurity
    
52.     Set wb = Workbooks(wbname)
    
53.     If Err.Number <> 0 Then
    
54.         Err.Clear
    
55.         MsgBox ThisWorkbook.Path & Slash & wb
    
56.         '防止打开时运行宏
    
57.         secAutomation = Application.AutomationSecurity
    
58.         Application.AutomationSecurity = msoAutomationSecurityForceDisable
    
59.         Set wb = Workbooks.Open(ThisWorkbook.Path & Slash & wbname)
    
60.         If Err.Number <> 0 Then
    
61.             MsgBox "打开 " & wb & " 出错"
    
62.             Err.Clear
    
63.             Exit Sub
    
64.         End If
    
65.     End If
    
66.    
    
67.     wb.Activate
    
68. 
    
69.     Dim arrKey, wbZong$, keyitem, endrow2&, endrow&
    
70.     For Each keyitem In dic.keys
    
71.         With Worksheets(keyitem)
    
72.             If Err.Number = 0 Then
    
73.                 .Range("d:e").NumberFormatLocal = "@"
    
74.                 .Range("f:f").NumberFormatLocal = "G/通用格式"
    
75.                  endrow = .Range("c" & Rows.Count).End(xlUp).Row = 3
    
76.                 If endrow > 3 Then
    
77.                     .Range("a4:j" & endrow).ClearContents
    
78.                     .Range("a4:j" & endrow).Borders.LineStyle = xlNone
    
79.                 End If
    
80.                 endrow = 4
    
81.                 arr2 = WorksheetFunction.Transpose(dic(keyitem)(1))
    
82.                 .Range("a" & endrow).Resize(UBound(arr2), 10) = arr2
    
83.                 endrow2 = .Range("c" & Rows.Count).End(xlUp).Row
    
84.                 .Range("f" & endrow).FormulaR1C1 = "=IF(COUNTIF(R4C[5]:RC11,RC[-1]&""*"")=1,""√"","""")"
    
85.                 .Range("f" & endrow & ":f" & endrow2).FillDown
    
86.                 With .Range("a" & 3 & ":j" & endrow2).Borders
    
87.                         .LineStyle = xlContinuous
    
88.                 End With
    
89.                 .Range("a:j").Columns.AutoFit
    
90.             End If
    
91.             Err.Clear
    
92.         End With
    
93.     Next
    
94.     Application.AutomationSecurity = msoAutomationSecurityByUI
    
95. End Sub
    

复制代码

新会甜橙

hwc2ycy 发表于 2012-12-3 13:25

老师,还有要求是拆分的各工作表无需调整格式,因为已调整好各表的打印格式了,只需填入内容就行了,望解决,多谢!

hwc2ycy

1. Sub 数据3()
   
2.     Dim arr
   
3.     Dim iRow&, i&, wbzb$
   
4.    
   
5.     '读取总表源数据
   
6.     wbzb = "总表"
   
7.     ThisWorkbook.Activate
   
8.     With Worksheets(wbzb)
   
9.         If Len(.[a3]) = 0 Then Exit Sub
   
10.         '高级筛选,去除重复值
    
11.         .Range("a3").CurrentRegion.AdvancedFilter xlFilterInPlace, , , True
    
12.         iRow = .Range("c" & Rows.Count).End(xlUp).Row
    
13.         If iRow <= 3 Then Exit Sub  '最后一行数据行低于第3行位置就退出
    
14.         arr = .Range("a3:i" & iRow)
    
15.     End With
    
16.    
    
17.     'arr2数组存储数据
    
18.     Dim dic As Object, arr2(), k&, j&
    
19.     '数据列对应关系，arrZos源列号，arrMpos目标列号
    
20.     Dim arrZPos, arrMPos, arrTemp
    
21.     arrZPos = Array(4, 5, 6, 7, 8, 9)
    
22.     arrMPos = Array(1, 2, 3, 4, 5, 10)
    
23.    
    
24.     '以支行网点名字存入字典
    
25.     Set dic = CreateObject("Scripting.dictionary")
    
26.     For i = 2 To UBound(arr)
    
27.         If Not dic.exists(arr(i, 3)) Then
    
28.             ReDim arr2(1 To 10, 1 To 1)
    
29.             For j = LBound(arrZPos) To UBound(arrZPos)
    
30.                 arr2(arrMPos(j), 1) = arr(i, arrZPos(j))
    
31.             Next
    
32.             dic(arr(i, 3)) = Array(1, arr2) '0为存入个数，1为数组
    
33.         Else
    
34.             arrTemp = dic(arr(i, 3))
    
35.             k = arrTemp(0) + 1
    
36.             arr2 = arrTemp(1)
    
37.             ReDim Preserve arr2(1 To 10, 1 To k)
    
38.             For j = LBound(arrZPos) To UBound(arrZPos)
    
39.                 arr2(arrMPos(j), k) = arr(i, arrZPos(j))
    
40.             Next
    
41.             dic(arr(i, 3)) = Array(k, arr2)
    
42.         End If
    
43.     Next
    
44. 
    
45.     On Error Resume Next
    
46.     Dim wb As Workbook
    
47.     Dim wbname$, Slash$
    
48.     wbname = "明细.xls"
    
49.     Slash = Application.PathSeparator
    
50. 
    
51.     Dim secAutomation As MsoAutomationSecurity
    
52.     Set wb = Workbooks(wbname)
    
53.     If Err.Number <> 0 Then
    
54.         Err.Clear
    
55.         MsgBox ThisWorkbook.Path & Slash & wb
    
56.         '防止打开时运行宏
    
57.         secAutomation = Application.AutomationSecurity
    
58.         Application.AutomationSecurity = msoAutomationSecurityForceDisable
    
59.         Set wb = Workbooks.Open(ThisWorkbook.Path & Slash & wbname)
    
60.         If Err.Number <> 0 Then
    
61.             MsgBox "打开 " & wb & " 出错"
    
62.             Err.Clear
    
63.             Exit Sub
    
64.         End If
    
65.     End If
    
66.    
    
67.     wb.Activate
    
68. 
    
69.     Dim arrKey, wbZong$, keyitem, endrow2&, endrow&
    
70.     For Each keyitem In dic.keys
    
71.         With Worksheets(keyitem)
    
72.             If Err.Number = 0 Then
    
73.                 .Range("d:e").NumberFormatLocal = "@"
    
74.                 .Range("f:f").NumberFormatLocal = "G/通用格式"
    
75.                  endrow = .Range("c" & Rows.Count).End(xlUp).Row = 3
    
76.                 If endrow > 3 Then
    
77.                     .Range("a4:j" & endrow).ClearContents
    
78.                     .Range("a4:j" & endrow).Borders.LineStyle = xlNone
    
79.                 End If
    
80.                 endrow = 4
    
81.                 arr2 = WorksheetFunction.Transpose(dic(keyitem)(1))
    
82.                 .Range("a" & endrow).Resize(UBound(arr2), 10) = arr2
    
83.                 endrow2 = .Range("c" & Rows.Count).End(xlUp).Row
    
84.                 .Range("f" & endrow).FormulaR1C1 = "=IF(COUNTIF(R4C[5]:RC11,RC[-1]&""*"")=1,""√"","""")"
    
85.                 .Range("f" & endrow & ":f" & endrow2).FillDown
    
86.                 End If
    
87.             Err.Clear
    
88.         End With
    
89.     Next
    
90.     Application.AutomationSecurity = msoAutomationSecurityByUI
    
91. End Sub
    

复制代码

新会甜橙

hwc2ycy 发表于 2012-12-3 20:23

感谢老师,太完美了