求高手解这个文件合并的难题

61kun

  1、求高手写个代码，将文件夹中的所有源文件像这样横着排列合并

  2、要求不能更改源文件格式，源文件在附近中
  3、每日增减新人，以最新日的人数改变之前日的行数并且对齐，比如17日增加了“王二”
日期  学号  姓名  得分  日期  学号  姓名  得分
   16日  100  张三  99  17日  100  张三  88
   16日  101  李四  95  17日  101  李四  89
   16日  102  王二  NO  17日  102  王二  77
   16日  103  刘七  99  17日  103  刘七  88

qingc0221

没什么用,时间长了就会有上百列,查看都不方便

61kun

居然没人帮俺了……55555555555

mhps159357

太复杂了！伤脑壳

liangmutou01

3、每日增减新人，以最新日的人数改变之前日的行数并且对齐，比如17日增加了“王二”


以最新日的人数改变之前日的行数，是以最新日的人数为准，将以前多余的人删除？还只是改变行位置，与最新日的人对齐？

蓝桥玄霜

2楼的意见是对的。
全部用代码实现，是可以的，但是过程会比较多：先要获取文件夹中所有的文件名、按日期排序以获得最新的日期以决定数据的行数、位置，然后用字典获取每一个人的行的位置。再逐日输入提取的数据等等。
建议这样显示数据：请见附图。

ivccav

这种烂问题，真有人帮你，那是吃饱了没事做。数据结构是错误的，再好的程序员也得累到。
曾经用几天时间回答过一个问题，也是这种没有意义的问题，他要把每个人的证书信息在窗体上横着放，毫无扩展性，哎。

魂断蓝桥

61kun 发表于 2019-1-19 21:33
居然没人帮俺了……55555555555

就当练习sql语句了

文件合并的难题.rar (31.22 KB, 下载次数: 1)

2019-1-25 13:59 上传

点击文件名下载附件

Option Explicit

Sub a()
Dim cn As New ADODB.Connection
Dim r As New ADODB.Recordset
Dim cnn As New cConnection
Dim rs As New cRecordset
Dim myf$, sql$, s$, m%, i%, rq$, bt
On Error GoTo 100
bt = Array("日期", "学号", "姓名", "得分")
cnn.CreateNewDB ":memory:"
sql = "create table t(日期 text,学号 TEXT,姓名 TEXT,得分 text)"
cnn.Execute sql
myf = Dir(ThisWorkbook.Path & "\*.xls")
cnn.BeginTrans
Do While myf <> ""
    If Left(myf, 1) <> "~" And myf <> ThisWorkbook.Name Then
        m = m + 1
        cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=YES'; Data Source=" & myf
        sql = "select * from [" & Replace(myf, ".xls", "") & "$a1:d] where 日期 is not null"
         r.Open sql, cn, 1, 1
         Do While Not r.EOF
            s = "'" & r.Fields(0) & "','" & r.Fields(1) & "','" & r.Fields(2) & "'," & r.Fields(3)
            sql = "insert into t values(" & s & ")"
            cnn.Execute sql
            r.MoveNext
         Loop
    End If
    myf = Dir()
     If r.State Then r.Close
    If cn.State Then cn.Close
Loop
cnn.CommitTrans
sql = "create table tmp(学号,姓名)"
cnn.Execute sql
sql = "INSERT INTO tmp SELECT DISTINCT 学号,姓名 FROM t order by 学号"
cnn.Execute sql
sql = "create table 日期(日期 text)"
cnn.Execute sql
sql = "INSERT INTO 日期 SELECT DISTINCT 日期 FROM t order by 日期"
cnn.Execute sql
Set cn = Nothing
Set r = Nothing
[a8:z99] = ""
Dim ARR
sql = "SELECT 日期 FROM 日期"
rs.OpenRecordset sql, cnn
ARR = rs.GetRows
Cells.Clear
For i = 1 To m
    sql = "SELECT A.日期,A.学号,A.姓名,ifnull(B.得分,""NO"") AS 得分 FROM (select 日期,学号,姓名 from 日期,tmp) AS A " _
        & "LEFT JOIN (SELECT 学号,得分 from t where 日期='" & ARR(0, i - 1) & "') AS B " _
        & "on A.学号=B.学号 WHERE 日期='" & ARR(0, i - 1) & "'"
    rs.OpenRecordset sql, cnn
    [a1].Offset(0, (i - 1) * 4).Resize(1, 4) = bt
    Range("a2").Offset(0, (i - 1) * 4).CopyFromRecordset rs.GetADORsFromContent
Next
Set cnn = Nothing
Set rs = Nothing
Exit Sub
100:
    Stop
End Sub

魂断蓝桥

代码审核中，先上附件
文件合并的难题.rar (31.22 KB, 下载次数: 1)

2019-1-25 14:00 上传

点击文件名下载附件