求助褚老师，此附件是用你写的代码，我试套可以使用，但想更改不提取名称如何做到

qinhuan66

求助褚老师，此附件是用你写的代码，我试套可以使用，但想更改不提取名称如何做到




求助2.rar (64.38 KB, 下载次数: 1)

2019-6-21 16:47 上传

点击文件名下载附件

qinhuan66

1. Sub test()'来自褚老师
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim mypath$, myname$
   
5.   Dim wb As Workbook
   
6.   Dim ws As Worksheet
   
7.   Dim d As Object
   
8.   Dim rng1 As Range
   
9.   Dim rng2 As Range
   
10.   Set d = CreateObject("scripting.dictionary")
    
11.   Dim reg As New RegExp
    
12.   tt = Timer
    
13.   Application.ScreenUpdating = False
    
14.   Application.DisplayAlerts = False
    
15.   mypath1 = ThisWorkbook.Path & "\原始数据"
    
16.   mypath2 = ThisWorkbook.Path & "\需生成的效果数据"
    
17.   myname = Dir(mypath1 & "*.xls")
    
18.   With reg
    
19.     .Pattern = "\d{4}"
    
20.   End With
    
21.   With Worksheets("sheet1")
    
22.     Set rng1 = .Range("a1:K7")
    
23.     Set rng2 = .Range("a8:K8")
    
24.   End With
    
25.   Do While myname <> ""
    
26.     If reg.test(myname) Then
    
27.       Set mh = reg.Execute(myname)
    
28.       nf = mh(0)
    
29.       Set wb = GetObject(mypath1 & myname)
    
30.       With wb
    
31.         With .Worksheets("sheet1")
    
32.           r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
33.           If .Cells(r, 1).MergeCells Then
    
34.             r = r - 1
    
35.           End If
    
36.           If InStr(.Range("a1"), "附件") <> 0 And r > 7 Then
    
37.             arr = .Range("a1:L" & r)
    
38.             For i = 8 To UBound(arr)
    
39.               If Not d.exists(arr(i, 12)) Then
    
40.                 Set d(arr(i, 12)) = CreateObject("scripting.dictionary")
    
41.               End If
    
42.               If Not d(arr(i, 12)).exists(nf) Then
    
43.                 m = 1
    
44.                 ReDim brr(1 To UBound(arr, 2), 1 To m)
    
45.               Else
    
46.                 brr = d(arr(i, 12))(nf)
    
47.                 m = UBound(brr, 2) + 1
    
48.                 ReDim Preserve brr(1 To UBound(arr, 2), 1 To m)
    
49.               End If
    
50.               brr(1, m) = m
    
51.               For j = 2 To UBound(arr, 2)
    
52.                 brr(j, m) = arr(i, j)
    
53.               Next
    
54.               d(arr(i, 12))(nf) = brr
    
55.             Next
    
56.           End If
    
57.         End With
    
58.         .Close False
    
59.       End With
    
60.     End If
    
61.     myname = Dir()
    
62.   Loop
    
63.   For Each aa In d.keys
    
64.     Application.SheetsInNewWorkbook = d(aa).Count
    
65.     Set wb = Workbooks.Add
    
66.     With wb
    
67.       m = 0
    
68.       For Each bb In d(aa).keys
    
69.         m = m + 1
    
70.         brr = d(aa)(bb)
    
71.         ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
72.         For i = 1 To UBound(brr)
    
73.           For j = 1 To UBound(brr, 2)
    
74.             crr(j, i) = brr(i, j)
    
75.           Next
    
76.         Next
    
77.         With .Worksheets(m)
    
78.           .Name = bb
    
79.           rng1.Copy .Range("a1")
    
80.           .Range("a8").Resize(UBound(crr), UBound(crr, 2)) = crr
    
81.           r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    
82.           rng2.Copy .Cells(r, 1)
    
83.           .Range("a4:K" & r - 1).Borders.LineStyle = xlContinuous
    
84.           .Rows("1:" & r - 1).RowHeight = 25.5
    
85.           .Rows(r).RowHeight = 65.25
    
86.           .Buttons.Delete
    
87.         End With
    
88.       Next
    
89.       .SaveAs Filename:=mypath2 & aa & ".xls", FileFormat:=xlExcel8
    
90.       .Close False
    
91.     End With
    
92.   Next
    
93.   Application.ScreenUpdating = True
    
94.   MsgBox "统计完毕！共用时" & Timer - tt & "秒"
    
95. End Sub

复制代码

chxw68

修改好了。