求助，以前找到的一个数据汇总的vba如何加一列

我是谁1100.

如何修改，把备注列提取出来

lsc900707

修改好了，请测试：

我是谁1100.

lsc900707 发表于 2018-7-22 19:16
修改好了，请测试：

大佬，为啥不能用啊，drr(n, 7) = arr(j, 13)是指汇总表的第七列提取成分个表的第13列么，[a2:g5000].ClearContents   提取区域需要改成g列么，大佬，非常感谢

lsc900707

我是谁1100. 发表于 2018-7-23 10:07
大佬，为啥不能用啊，drr(n, 7) = arr(j, 13)是指汇总表的第七列提取成分个表的第13列么

对呀，你分表填好内容再试试。

我是谁1100.

lsc900707 发表于 2018-7-23 10:09
对呀，你分表填好内容再试试。

分户备注项填好后发现还是不可以，大佬可以看看么[a2:f5000].ClearContents,是不是要改成gxxxx

不知道为什么

我是谁1100. 发表于 2018-7-23 10:29
分户备注项填好后发现还是不可以，大佬可以看看么[a2:f5000].ClearContents,是不是要改成gxxxx

自己啥都懂，为何自己不试试？

lsc900707

1. Public brr(), r&
   
2. 
   
3. Sub lqxs()
   
4.   Dim arr, mypath$, myr&
   
5.   Dim i&, n&, j&, nm$, drr(1 To 5000, 1 To 7)
   
6.   Application.ScreenUpdating = False
   
7.   [a2:g5000].ClearContents
   
8.   r = 0
   
9.   mypath = ThisWorkbook.Path & ""
   
10.   Call searfile(mypath, ".xlsx")
    
11.   For i = 1 To UBound(brr, 2)
    
12.     nm = Split(brr(2, i), "-")(0)
    
13.     With GetObject(brr(1, i) & brr(2, i))
    
14.     myr = .Sheets(1).Cells(.Sheets(1).Rows.Count, 4).End(xlUp).Row
    
15.     arr = .Sheets(1).Range("a31:o" & myr)
    
16.     .Close False
    
17.     End With
    
18.     For j = 1 To UBound(arr)
    
19.       n = n + 1
    
20.       If j = 1 Then
    
21.         drr(n, 1) = nm
    
22.       End If
    
23.       drr(n, 2) = arr(j, 1): drr(n, 3) = arr(j, 4): drr(n, 4) = arr(j, 6): drr(n, 5) = arr(j, 8): drr(n, 6) = arr(j, 10): drr(n, 7) = arr(j, 14)
    
24.     Next
    
25.   Next
    
26.   Columns(6).NumberFormatLocal = "@"
    
27.   [a2].Resize(n, 7) = drr
    
28.   Application.ScreenUpdating = True
    
29.   MsgBox "ok"
    
30. End Sub
    
31. 
    
32. Sub searfile(fp As String, fkey As String)
    
33.   Dim arr1() As String
    
34.   Dim i1 As Integer
    
35.   Dim i2 As Integer
    
36.   Dim fm
    
37.   If Right(fp, 1) <> "" Then
    
38.     fp = fp & ""
    
39.   End If
    
40.   If Len(fkey) < 1 Then
    
41.     fkey = ".xls"
    
42.   End If
    
43.   fm = Dir(fp, vbDirectory)
    
44.   Do While fm <> ""
    
45.     If fm <> "." And fm <> ".." Then
    
46.       If (GetAttr(fp & fm) And vbDirectory) = vbDirectory Then
    
47.         i1 = i1 + 1
    
48.         ReDim Preserve arr1(1 To i1)
    
49.         arr1(i1) = fp & fm
    
50.       End If
    
51.       If Right(fm, Len(fkey)) = fkey Then
    
52.         r = r + 1
    
53.         ReDim Preserve brr(1 To 2, 0 To r)
    
54.         brr(1, r) = fp
    
55.         brr(2, r) = fm
    
56.       End If
    
57.     End If
    
58.     fm = Dir
    
59.   Loop
    
60.   For i2 = 1 To i1
    
61.     Call searfile(arr1(i2), fkey)
    
62.   Next
    
63. End Sub
    

复制代码

lsc900707

我是谁1100. 发表于 2018-7-23 10:29
分户备注项填好后发现还是不可以，大佬可以看看么[a2:f5000].ClearContents,是不是要改成gxxxx

传不了附件，自己把代码修改一下吧。

jjmysjg

arr = .Sheets(1).Range("a31:O" & myr)
drr(n, 7) = arr(j, 14)
留个记号