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

定敏

魂断蓝桥 发表于 2016-8-25 14:27
Sub hz()
Dim myfile$, mypath$, sch$, t%
mypath = ThisWorkbook.Path & "\"

多谢老师，又帮解决了一个困惑我已很久的难题。
代码太高大上了，我一句都看不懂，能给每一句加个注释吗？

定敏

魂断蓝桥 发表于 2016-8-25 14:27
Sub hz()
Dim myfile$, mypath$, sch$, t%
mypath = ThisWorkbook.Path & "\"

当我加入相同结构的更多的村的表时，怎么出错了？

kszcs

魂断蓝桥 发表于 2016-8-25 14:27
Sub hz()
Dim myfile$, mypath$, sch$, t%
mypath = ThisWorkbook.Path & "\"

魂断蓝桥老师你好！
9楼的代码直观。怎么修改能达到目的？
谢谢

定敏

魂断蓝桥 发表于 2016-8-25 14:27
Sub hz()
Dim myfile$, mypath$, sch$, t%
mypath = ThisWorkbook.Path & "\"

就是这个附件，我把全乡所有的表复制进来，代码就出现错误了。

d346836673

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

很好   很强大！

定敏

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

老师您好，为了生成外来就读的学生名单，我试着套用您的代码，实现了大部分功能，可还有一些不该出现的内容也出现了（如一些空格，有的学校还把表头也复制了上来），您能帮我看看问题出现在哪里吗？谢谢

Sub test21()
  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:l" & 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 10, 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) = Mid(xmarr, 6, 4)
              brr(10, m) = arr(i, 12)
            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-29 10:01
老师您好，为了生成外来就读的学生名单，我试着套用您的代码，实现了大部分功能，可还有一些不该出现的 ...

1、茅贡村2015年秋季名册生成阶梯表.xls 此工作表a4单元格并没有学校名称，需要添加【学校名称：茅贡小学】
2、全镇在外就读学生名册.xls 此工作表不应该再汇总，需要先删除，或修改代码
3、你的数据太不规范了，比如寨头村，出生日期好多都是文本。

20020617

20010803

20030327

代码中只能把这些变成空文本，这个是ado的特性

Option Explicit

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 999, 1 To 11)
Do While myfile <> ""
    If myfile <> ThisWorkbook.Name And myfile <> "全镇在外就读学生名册.xls" 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
        sch = Left(myfile, 3)
        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
                                If y = 5 Then
                                    If IsNumeric(crr(y - 1, m)) Then
                                        brr(x, y + 1) = Val(crr(y - 1, m))
                                       
                                    Else
                                        brr(x, y + 1) = ""
                                    End If
                                Else
                                    brr(x, y + 1) = crr(y - 1, m)
                                End If
                            Next
                                brr(x, 11) = sch & "小学"
                                brr(x, 1) = x
                    Next
            End If
    End If
        myfile = Dir()
Loop
Cells.ClearContents
[a2].Resize(x, 11) = brr
Set cnn = Nothing
End Sub

定敏

魂断蓝桥 发表于 2016-8-30 08:52
1、茅贡村2015年秋季名册生成阶梯表.xls 此工作表a4单元格并没有学校名称，需要添加【学校名称：茅贡小 ...

谢谢您老师，对我的表这么细心地审查与修改，帮了我的大忙。这些表都是各村校的老师报来的，他们有的不懂电脑，所以报来的表很多都不规范，由于表太多了，所以我在汇总时也疏忽了。
可是，老师，为什么有的学生的出生日期导过来是空的呢，比如第一个学生，他在原表中的数据是日期格式，可为什么会是空的呢？该怎样修改？

魂断蓝桥

定敏 发表于 2016-8-30 09:30
谢谢您老师，对我的表这么细心地审查与修改，帮了我的大忙。这些表都是各村校的老师报来的，他们有的不懂 ...

还是需要从原始表格入手，修改原始表格。


全乡各村工作表.rar (1.16 MB, 下载次数: 11)

2016-8-30 11:05 上传

点击文件名下载附件

定敏

魂断蓝桥 发表于 2016-8-30 11:05
还是需要从原始表格入手，修改原始表格。

多谢老师，不厌其烦地帮我解决了出生日期是空白的问题，可是，时间怎么变了，比如第一个，原来的出生日期是“2007/10/1”，而结果却变成了“1905/6/29”，诸如此类还有很多，能够再加以修改吗？谢谢。