如何遍历文件夹中各分表，生成一个集中表

定敏

在同一文件夹中，有全镇各个村的表，如何从各村的《岁段名册总表》中，找出R列有详细内容的记录，并集中生成在一个表中。每年都得手工做这个，太难了，想到救助VBA可以实现这个功能，无奈自己对VBA的掌握程度只是在录制宏阶段，只好求助老师们了，谢谢。


这是每个村的样表。



这是想要实现自动填写的表，还要在上面加个按钮。

新建文件夹.rar (222.55 KB, 下载次数: 14)

2016-8-25 10:17 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%, m%
   
3.   Dim arr, brr()
   
4.   Dim mypath$, myname$
   
5.   Dim ws As Worksheet
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   mypath = ThisWorkbook.Path
   
9.   myname = Dir(mypath & "\*.xls")
   
10.   Do While myname <> ""
    
11.     If myname <> ThisWorkbook.Name Then
    
12.       Set wb = GetObject(mypath & "" & myname)
    
13.       With wb
    
14.         With .Worksheets("岁段名册总表")
    
15.           r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
16.           arr = .Range("a9:s" & r)
    
17.           For i = 1 To UBound(arr)
    
18.             If Len(arr(i, 18)) > 1 Then
    
19.               m = m + 1
    
20.               ReDim Preserve brr(1 To 7, 1 To m)
    
21.               brr(1, m) = arr(i, 1)
    
22.               brr(2, m) = arr(i, 8)
    
23.               brr(3, m) = arr(i, 3)
    
24.               brr(4, m) = arr(i, 4)
    
25.               brr(5, m) = arr(i, 7)
    
26.               brr(6, m) = arr(i, 18)
    
27.               brr(7, m) = arr(i, 11)
    
28.             End If
    
29.           Next
    
30.         End With
    
31.         .Close
    
32.       End With
    
33.     End If
    
34.     myname = Dir()
    
35.   Loop
    
36.   With Worksheets("全镇在外就读学生名册")
    
37.     .UsedRange.Offset(4, 0).Clear
    
38.     .Range("a5").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
    
39.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
40.     .Range("a4:g" & r).Borders.LineStyle = xlContinuous
    
41.   End With
    
42. End Sub
    

复制代码

chxw68

详见附件。

定敏

chxw68 发表于 2016-8-25 10:45
详见附件。

非常感谢您，这么快就帮我做好了，不愧是侠圣呀，真是让我又佩服又感激，再次感谢。

kszcs

chxw68 发表于 2016-8-25 10:45

chxw68老师你好！
条件改为“R列有数据的整行集中到一个表中”，怎么修改你的代码?
谢谢！

liumiaomiao

chxw68 发表于 2016-8-25 10:45

请看看序号417和433这两个人

定敏

liumiaomiao 发表于 2016-8-25 12:05
请看看序号417和433这两个人

是原表没有将这两年人的就读年级填上，老师做的表没有错。

定敏

接下来，难度升级：现在是根据各村的《在校生花名册》生成的外来就读学生名册——在某个村的《在校生花名册》中，如果某一个学生的家庭地址与学校不为同一个村名，即为外来就读学生。（即A4的“XX小学”中的“小学”二字前的两个字（XX）为村名，当J列中没有此两字时，即为外地来的学生）。


新建文件夹1.rar (234.64 KB, 下载次数: 6)

2016-8-25 13:14 上传

点击文件名下载附件

定敏

chxw68 发表于 2016-8-25 10:45

我试着套用chxw68 老师的代码想用来完成8楼的功能，可不知为什么总是不能出现我要的结果，这是哪里有问题了：

Sub test1()
  Dim r%, i%, m%
  Dim arr, brr()
  Dim mypath$, myname$
  Dim ws As Worksheet
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  mypath = ThisWorkbook.Path
  myname = Dir(mypath & "\*.xls")
  Do While myname <> ""
    If myname <> ThisWorkbook.Name Then
      Set wb = GetObject(mypath & "\" & myname)
      With wb
        With .Worksheets("在校生名册")
          r = .Cells(.Rows.Count, 1).End(xlUp).Row
          arr = .Range("a8:p" & r)
          xmarr = .Range("a4")
          For i = 1 To UBound(arr)
            If Mid(arr(i, 10), 7, 2) <> Left(Right(xmarr, 4), 2) Then
              m = m + 1
              ReDim Preserve brr(1 To 12, 1 To m)
              brr(1, m) = m
              brr(2, m) = arr(i, 4)
              brr(3, m) = arr(i, 5)
              brr(4, m) = arr(i, 6)
              brr(5, m) = arr(i, 7)
              brr(6, m) = arr(i, 8)
              brr(7, m) = arr(i, 9)
              brr(8, m) = arr(i, 10)
              brr(9, m) = arr(i, 11)
              brr(10, m) = Mid(xmarr, 6, 4)              
            End If
          Next
        End With
        .Close
      End With
    End If
    myname = Dir()
  Loop
  With Worksheets("外来就读学生名册")
    .UsedRange.Offset(4, 0).Clear
    .Range("a5").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("a4:g" & r).Borders.LineStyle = xlContinuous
  End With
End Sub

魂断蓝桥

定敏 发表于 2016-8-25 13:14
接下来，难度升级：现在是根据各村的《在校生花名册》生成的外来就读学生名册——在某个村的《在校生花名册 ...

Sub hz()
Dim myfile$, mypath$, sch$, t%
mypath = ThisWorkbook.Path & "\"
myfile = Dir(mypath & "*.xls")
Dim cnn As Object, rs As Object, SQL$, x As Integer, y As Integer, m As Integer, crr, brr(1 To 9999, 1 To 11)
Do While myfile <> ""
    If myfile <> ThisWorkbook.Name Then
        Set cnn = CreateObject("ADODB.Connection")
        Set rs = CreateObject("adodb.Recordset")
        cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=NO'; Data Source=" & mypath & myfile
        SQL = "select * from [在校生名册$a4:a4]"
        sch = cnn.Execute(SQL)(0)
        t = Val(InStr(sch, "小学"))
        sch = Mid(sch, t - 2, 2)
        SQL = "select * from [在校生名册$D8:L] where F7 NOT LIKE '%" & sch & "%'"
        rs.Open SQL, cnn, 1, 1
            If rs.RecordCount > 0 Then
                Set rs = cnn.Execute(SQL)
                crr = rs.getRows
                    For m = 0 To UBound(crr, 2)
                        x = x + 1
                            For y = 1 To UBound(crr) + 1
                                brr(x, y + 1) = crr(y - 1, m)
                            Next
                                brr(x, 11) = sch
                                brr(x, 1) = x
                    Next
            End If
    End If
        myfile = Dir()
Loop
[a6:L9999].ClearContents
[A6].Resize(x, 11) = brr
Set cnn = Nothing
End Sub