EXCEL相同表格工作表合并的问题

flomasign

之前在论坛下载“相同格式的几千个工作簿合并”表格，实现数据汇总的效果，但实际测试发现运行后数据消失(尝试更改了部分看得懂的代码）。
本人新手，大段代码看不懂，网上查了半天也没有头绪，所以请教各位指点。
附件“XRF有害物质测试记录(A1)“为汇总表，运行"GP"按钮选择导入工作表“01-002058-03 PAD”的数据。
此外，“HF”按钮需实现以下功能：
1.同“GP”一样导入外部工作表数据（如工作表“01-002058-03 PAD HF")；
2.运行"GP"后再运行"HF"，如D列数据存在，则只覆盖P列及S列的数据；如“HF”D列数据为新增，则提示错误信息（“新增数据”无GP报告）
以上感谢！

winnerzjt

HF没看到呀

flomasign

winnerzjt 发表于 2015-5-29 14:12
HF没看到呀

HF代码没写，不知道如何写啊，我想先把前面的弄完。

flomasign

请问哪位高手能帮忙解答下，元始代码是从A2开始的，我想从A5开始，但将参数改为"A5"运行后，表格中内容全都消失了。如附件，感谢。

flomasign

附上之前论坛老师提供的代码（修改红色部分后运行后数据消失）：
Dim strSQL, s, Mypath$, OutputSheet$, OutputRange$, strCondition$
Sub 载入数据()
    strSQL = "select * " & _
             " from"
    strCondition = "WHERE 车间 IS NOT NULL "
    OutputSheet = "结果"
    OutputRange = "A2"
    Call subProgram(strSQL, OutputSheet, OutputRange, strCondition)
    MsgBox "OK"
End Sub

Sub subProgram(ByVal strSQL$, ByVal OutputSheet$, ByVal OutputRange$, ByVal strCondition$)
    Dim cnn As Object, rst As Object, rs As Object
    Dim strConn As String, SQL$
    Dim i As Integer, j%, Pathstr, s$, t$, sProvider$
    Pathstr = Application.GetOpenFilename(fileFilter:="Excel文件(*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="打开Excel文件", MultiSelect:=True) '选择多个EXCCEL 文件
    If TypeName(Pathstr) = "Boolean" Then Exit Sub
    Application.ScreenUpdating = False
    Select Case Application.Version * 1
        Case Is <= 11
            sProvider = "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0';Data Source ="
        Case Is >= 12
            sProvider = "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties ='Excel 12.0';Data Source ="
    End Select
    On Error Resume Next
    With Sheets(OutputSheet)
        .Cells.ClearContents
        For i = 1 To UBound(Pathstr)
            If Pathstr(i) <> ThisWorkbook.FullName Then
                Set cnn = CreateObject("ADODB.Connection")
                cnn.Open sProvider & Pathstr(i)
                Set rs = cnn.OpenSchema(20)
                Do Until rs.EOF
                    If rs.Fields("TABLE_TYPE") = "TABLE" Then
                        s = Replace(rs("TABLE_NAME").Value, "'", "")
                        If Right(s, 1) = "$" Then
                            SQL = strSQL & "[" & s & "] " & strCondition
                            Set rst = cnn.Execute(SQL)
                            If Err.Number = 0 Then
                                m = m + 1
                                If m = 1 Then
                                    For j = 0 To rst.Fields.Count - 1
                                        .Cells(1, j + 1) = rst.Fields(j).Name
                                    Next
                                    .Range("A2").CopyFromRecordset rst
                                Else
                                    .Range("A1048576").End(xlUp).Offset(1).CopyFromRecordset rst
                                End If
                               ' Exit Do'此句不能启用，记住了！否则有一个工作簿有二个表的，只能提取到一个。
                            Else
                                Err.Clear
                            End If
                        End If
                    End If
                    rs.MoveNext
                Loop
            End If
        Next
        Cells.EntireColumn.AutoFit
    End With
    rst.Close
    rs.Close
    cnn.Close
    Set cnn = Nothing
    Set rs = Nothing
    Set rst = Nothing
    Application.ScreenUpdating = True
End Sub

LMY123

Set rs = cnn.OpenSchema(20)