[已解决]【求助】大佬们帮帮忙对比文件中的值

qsr130628

循环遍历1文件夹下及子文件夹所有的Excel文件 中的E6、F6 的值与text0.xlsx文件的M、N列的值对比 若是相同则将所对应的A、B、C、D列的值写入到新建Excel文件（样本.xlsx）的A、B、C、D   并将对比的值写入到F列以下划线分割    新建Excel文件（样本.xlsx）的H列写入对比相同的text0.xlsx文件的绝对路径 谢谢各位老师。。。

最佳答案

月排行榜 / 总排行榜

wc110wc110

2017-9-21 18:05

3.rar (70.86 KB, 下载次数: 9)

2017-9-22 09:39 上传

点击文件名下载附件 代码在text0.xlsm “模块一”里面，text0.xlsm名字不能更改 。子文件夹里的工作簿也能读取比较，请测试。样表里记录的目标工作簿的地址用的是绝对地址。每一次运行，样表都是重新统计，不是加在后面。text0.xlsm里的sheet2必须保留，否则报错，原理是我先将结果写入sheet2，然后在copy出来，然后在将sheet2 清空。
Sub ceshi2214()

    Dim filename As String, haha As String, jaja As String, arr1(1 To 100000) As Variant, arr2(1 To 10000) As Variant
    Dim i As Integer, k As Integer, j As Integer, kaka As Variant, t As Long, qz1 As Variant, qz2 As Variant
    Dim dz1 As String, kk1 As Variant, kk As Variant, t1 As Long, t2 As Long, t3 As Long, t4 As Long, t5 As Long, ls2 As String, t6 As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Workbooks("text0.xlsm").Worksheets(1)
        dz1 = .Range("m65536").End(xlUp).Address
        kk = Split(dz1, "$")
        kk1 = kk(2) '行号
        t3 = kk1
        'MsgBox kk1
        For t1 = 2 To kk1
            If .Cells(t1, "m") <> "" Then
                Exit For
            End If
        Next
        dz1 = .Range("n65536").End(xlUp).Address
        kk = Split(dz1, "$")
        kk1 = kk(2) '行号
        t4 = kk1
        'MsgBox kk1
        For t2 = 2 To kk1
            If .Cells(t2, "m") <> "" Then
                Exit For
            End If
        Next
        'MsgBox t1
        'MsgBox t2
        't1,t2记录m n 列开始行号  t3,t4分别记录m，n行终止行号
    End With
    j = 1
    k = 1
    i = 1
    t5 = 2
    arr1(i) = ThisWorkbook.Path & "\"
    '设置目标文件夹
    Do
        If k > j Then
            Exit Do
        End If
        jaja = Dir(arr1(k), 16)
        'MsgBox "Dir(arr1(k), 16)=" & jaja
        Do
            jaja = Dir()
            'MsgBox "Dir()=" & jaja
            If jaja = "" Then
                Exit Do
            End If
            If jaja <> "." And jaja <> ".." Then
                ' 使用位比较来确定 MyName 代表一目录。
                If GetAttr(arr1(k) & jaja) = vbDirectory Then
                    ' 如果它是一个目录，将其地址写入arr1数组
                    j = j + 1
                    arr2(j) = arr1(k) & jaja
                    arr1(j) = arr1(k) & jaja & "\"
                    'MsgBox "第" & j & "项" & arr1(j)
                End If
            End If
        Loop
        k = k + 1
        'MsgBox "k为" & k
    Loop
    'MsgBox j
    For t6 = 2 To j
        kaka = Dir(arr1(t6))
        If kaka <> "" Then
            'MsgBox kaka
            'MsgBox arr1(t6) & kaka
            Workbooks.Open (arr1(t6) & kaka)
            qz1 = Range("e6")
            qz2 = Range("f6")
            ActiveWorkbook.Close
            'MsgBox qz1
            'MsgBox qz2
            ls2 = qz2 & "_" & qz1
            For t = t1 To t3
                If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "m") = qz1 Then
                    If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "n") = qz2 Then
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "a") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "a")
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "b") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "b")
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "c") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "c")
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "d") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "d")
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "f") = ls2
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "h") = arr1(t6) & kaka
                        t5 = t5 + 1
                        Exit For
                    End If
                End If
            Next
        End If
        Do
            If kaka = "" Then
                Exit Do
            End If
            kaka = Dir
            If kaka <> "" Then
                'MsgBox kaka
                'MsgBox arr1(t6) & kaka
                Workbooks.Open (arr1(t6) & kaka)
                qz1 = Range("e6")
                qz2 = Range("f6")
                ls2 = qz2 & "_" & qz1
                ActiveWorkbook.Close
                For t = t1 To t3
                    If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "m") = qz1 Then
                        If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "n") = qz2 Then
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "a") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "a")
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "b") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "b")
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "c") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "c")
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "d") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "d")
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "f") = ls2
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "h") = arr1(t6) & kaka
                            t5 = t5 + 1
                            Exit For
                        End If
                    End If
                Next
            End If
        Loop
    Next
    Workbooks("text0.xlsm").Worksheets(2).Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\样表.xlsx"
    ActiveWorkbook.Close
    Workbooks("text0.xlsm").Worksheets(2).Cells.ClearContents
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

跳转到最佳答案楼层

wc110wc110

3.rar (70.86 KB, 下载次数: 9)

2017-9-22 09:39 上传

点击文件名下载附件 代码在text0.xlsm “模块一”里面，text0.xlsm名字不能更改 。子文件夹里的工作簿也能读取比较，请测试。样表里记录的目标工作簿的地址用的是绝对地址。每一次运行，样表都是重新统计，不是加在后面。text0.xlsm里的sheet2必须保留，否则报错，原理是我先将结果写入sheet2，然后在copy出来，然后在将sheet2 清空。
Sub ceshi2214()

    Dim filename As String, haha As String, jaja As String, arr1(1 To 100000) As Variant, arr2(1 To 10000) As Variant
    Dim i As Integer, k As Integer, j As Integer, kaka As Variant, t As Long, qz1 As Variant, qz2 As Variant
    Dim dz1 As String, kk1 As Variant, kk As Variant, t1 As Long, t2 As Long, t3 As Long, t4 As Long, t5 As Long, ls2 As String, t6 As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Workbooks("text0.xlsm").Worksheets(1)
        dz1 = .Range("m65536").End(xlUp).Address
        kk = Split(dz1, "$")
        kk1 = kk(2) '行号
        t3 = kk1
        'MsgBox kk1
        For t1 = 2 To kk1
            If .Cells(t1, "m") <> "" Then
                Exit For
            End If
        Next
        dz1 = .Range("n65536").End(xlUp).Address
        kk = Split(dz1, "$")
        kk1 = kk(2) '行号
        t4 = kk1
        'MsgBox kk1
        For t2 = 2 To kk1
            If .Cells(t2, "m") <> "" Then
                Exit For
            End If
        Next
        'MsgBox t1
        'MsgBox t2
        't1,t2记录m n 列开始行号  t3,t4分别记录m，n行终止行号
    End With
    j = 1
    k = 1
    i = 1
    t5 = 2
    arr1(i) = ThisWorkbook.Path & "\"
    '设置目标文件夹
    Do
        If k > j Then
            Exit Do
        End If
        jaja = Dir(arr1(k), 16)
        'MsgBox "Dir(arr1(k), 16)=" & jaja
        Do
            jaja = Dir()
            'MsgBox "Dir()=" & jaja
            If jaja = "" Then
                Exit Do
            End If
            If jaja <> "." And jaja <> ".." Then
                ' 使用位比较来确定 MyName 代表一目录。
                If GetAttr(arr1(k) & jaja) = vbDirectory Then
                    ' 如果它是一个目录，将其地址写入arr1数组
                    j = j + 1
                    arr2(j) = arr1(k) & jaja
                    arr1(j) = arr1(k) & jaja & "\"
                    'MsgBox "第" & j & "项" & arr1(j)
                End If
            End If
        Loop
        k = k + 1
        'MsgBox "k为" & k
    Loop
    'MsgBox j
    For t6 = 2 To j
        kaka = Dir(arr1(t6))
        If kaka <> "" Then
            'MsgBox kaka
            'MsgBox arr1(t6) & kaka
            Workbooks.Open (arr1(t6) & kaka)
            qz1 = Range("e6")
            qz2 = Range("f6")
            ActiveWorkbook.Close
            'MsgBox qz1
            'MsgBox qz2
            ls2 = qz2 & "_" & qz1
            For t = t1 To t3
                If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "m") = qz1 Then
                    If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "n") = qz2 Then
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "a") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "a")
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "b") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "b")
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "c") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "c")
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "d") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "d")
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "f") = ls2
                        Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "h") = arr1(t6) & kaka
                        t5 = t5 + 1
                        Exit For
                    End If
                End If
            Next
        End If
        Do
            If kaka = "" Then
                Exit Do
            End If
            kaka = Dir
            If kaka <> "" Then
                'MsgBox kaka
                'MsgBox arr1(t6) & kaka
                Workbooks.Open (arr1(t6) & kaka)
                qz1 = Range("e6")
                qz2 = Range("f6")
                ls2 = qz2 & "_" & qz1
                ActiveWorkbook.Close
                For t = t1 To t3
                    If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "m") = qz1 Then
                        If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "n") = qz2 Then
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "a") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "a")
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "b") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "b")
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "c") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "c")
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "d") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "d")
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "f") = ls2
                            Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "h") = arr1(t6) & kaka
                            t5 = t5 + 1
                            Exit For
                        End If
                    End If
                Next
            End If
        Loop
    Next
    Workbooks("text0.xlsm").Worksheets(2).Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\样表.xlsx"
    ActiveWorkbook.Close
    Workbooks("text0.xlsm").Worksheets(2).Cells.ClearContents
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

jiahb2001

用ADO做了下

qsr130628

wc110wc110 发表于 2017-9-21 18:05
代码在text0.xlsm “模块一”里面 。子文件夹里的工作簿也能读取比较，请测试。样表里记录的目标工作簿的 ...

谢谢，可不可以在上传一次附件呢，我这边下载附件损坏了 加我Q也可以278072525

qsr130628

jiahb2001 发表于 2017-9-22 06:39
用ADO做了下

谢谢，大佬。。。。

wc110wc110

qsr130628 发表于 2017-9-22 10:19
谢谢，可不可以在上传一次附件呢，我这边下载附件损坏了 加我Q也可以278072525

我这边可以下载附件的啊，你重新下载试一下