Sub Macro1()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Dim a, b, d As Object, i&, arr, brr()
    Set d = CreateObject("scripting.dictionary")
    a = Array("a", "b")
    b = Array("c", "d")
    For i = 0 To UBound(a)
        d(a(i)) = b(i)
    Next
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("A4:X4")
    Set wb = GetObject(ThisWorkbook.Path & "\B.xls")
    j = sh.UsedRange.Find("*", , -4163, , 1, 2).Row + 1
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        With .Rows(2)
            For Each r In rng
                t = d(r.Value)
                If t <> "" Then
                    Set c = .Find(d(r.Value), , , 1)
                    If Not c Is Nothing Then
                        arr = c.Offset(1).Resize(lr + 1).Value
                        ReDim brr(1 To lr * 3, 1 To 1)
                        m = 0
                        For i = 1 To lr
                            For l = m + 1 To m + 3
                                brr(l, 1) = arr(i, 1)
                            Next
                            m = m + 3
                        Next
                        sh.Cells(j, r.Column).Resize(lr * 3).Value = brr
                    End If
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

Sub Macro1()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Dim a, b, d As Object, i&, arr, brr()
    Set d = CreateObject("scripting.dictionary")
    a = Array("a", "b")
    b = Array("c", "d")
    For i = 0 To UBound(a)
        d(a(i)) = b(i)
    Next
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("A4:X4")
    rng.Select
    Set wb = GetObject(ThisWorkbook.Path & "\B.xls")
    j = sh.UsedRange.Find("*", , -4163, , 1, 2).Row + 1
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        ReDim brr(1 To lr * 3, 1 To 1)
        With .Rows(2)
            For Each r In rng
                t = d(r.Value)
                If t <> "" Then
                    Set c = .Find(d(r.Value), , , 1)
                    If Not c Is Nothing Then
                        arr = c.Offset(1).Resize(lr + 1)
                        m = 0
                        For l = 1 To 3
                            For i = 1 To lr
                                m = m + 1
                                brr(m, 1) = arr(i, 1)
                            Next
                        Next
                        sh.Cells(j, r.Column).Resize(m).Value = brr
                    End If
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

Sub Macro1()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("F4:I4,N4:O4,Q4:R4,W4:X4")
    Set wb = GetObject(ThisWorkbook.Path & "\B.xls")
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        With .Rows(2)
            For Each r In rng
                Set c = .Find(r.Value, , , 1)
                If Not c Is Nothing Then
                    c.Offset(1).Resize(lr).Copy sh.Cells(65536, r.Column).End(xlUp).Offset(1)
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

Sub test1()
    Dim sz(), sz1, sz3, SZ2(), myRegExp As Object
    On Error Resume Next
    Set myRegExp = CreateObject("VBScript.RegExp")
    myRegExp.Global = True
    myRegExp.IgnoreCase = Ture
    myRegExp.Pattern = "[0-9][0-9][0-9][0-9]-[0-9][0-9]?-[0-9][0-9]?-[0-9][0-9]?.xls"
    s = Dir(xlapp.ActiveWorkbook.Path & "\*.xls")
    n = -1
    Do While s <> ""
        If s <> xlapp.ActiveWorkbook.Name Then
        If UCase(s) Like "*[0-9][0-9][0-9][0-9]-[0-9]*-[0-9]*-[0-9]*.XLS" Then
            n = n + 1
            ReDim Preserve sz(n)
            sz(n) = s
            If UCase(s) Like "??[0-9]*" Then
                ReDim Preserve SZ2(n)
                SZ2(n) = Mid(s, 3, 1)
            End If
        End If
        End If
        s = Dir
    Loop
 
    Set matchs = myRegExp.Execute(Join(sz, ","))
    If matchs.Count = 0 Then MsgBox "请检查文件名！", , "提示": Exit Sub
    ReDim sz1(2, 0)
    For i = 0 To matchs.Count - 1
        ReDim Preserve sz1(2, i)
        sz1(0, i) = matchs.Item(i)
        sz3 = Split(sz1(0, i), "-")
        sz1(1, i) = sz3(0) & "-" & sz3(1) & "-" & sz3(2)
        sz1(2, i) = Split(sz3(3), ".")(0)
    Next i
    xlapp.ScreenUpdating = False
    xlapp.Sheets(3).Activate
    With xlapp.Sheets(3)
        .Columns("A:d").ClearContents
        .[a1].Resize(UBound(sz1, 2) + 1, 3) = xlapp.Transpose(sz1)
        .[d1].Resize(UBound(SZ2) + 1) = xlapp.Transpose(SZ2)

        .[a1].CurrentRegion.Sort Key1:=xlapp.Range("d1"), Order1:=xlAscending, Key2:=xlapp.Range("b1"), Order2:=xlAscending, key3:=xlapp.Range("c1"), _
                                 order3:=xlAscending, Header:=xlGuess
        sz1 = xlapp.Transpose(.Range("A1:A" & .[a1].CurrentRegion.Rows.Count))
        SZ2 = xlapp.Transpose(.Range("d1:d" & .[d1].CurrentRegion.Rows.Count))

        .Columns("A:d").ClearContents
    End With
    For i = 1 To UBound(sz1)
        For ii = i - 1 To UBound(sz)
            If sz(ii) Like "??" & SZ2(i) & "*" & sz1(i) Then
                temp = sz(i - 1)
                sz(i - 1) = sz(ii)
                sz(ii) = temp
                Exit For
            End If
        Next ii
    Next i

    xlapp.Sheets(1).Activate
    xlapp.Rows("5:65536").Delete
    k = 250
    For i = 0 To UBound(sz)
        With GetObject(xlapp.ActiveWorkbook.Path & "\" & sz(i))
            For ii = 5 To .Sheets(1).Range("A65536").End(xlUp).Row
                If xlapp.ActiveWorkbook.Sheets(1).Range("A65536").End(xlUp).Row = 1 Then
                    mt = 200
                Else
                    mt = 2
                End If
                If .Sheets(1).Range("s" & ii) <> "" Then .Sheets(1).Rows(ii).Copy xlapp.ActiveWorkbook.Sheets(1).Range("A65536").End(xlUp)(mt + k): k = 0
            Next ii
            .Close False
        End With
    Next i

    xlapp.ScreenUpdating = True
End Sub

Sub Macro1()
    Dim sz(), sz1, SZ2(), myRegExp As Object
    On Error Resume Next
    Set myRegExp = CreateObject("VBScript.RegExp")
    myRegExp.Global = True
    myRegExp.IgnoreCase = Ture
    myRegExp.Pattern = "\d{4}-\d{1,2}-\d{1,2}-\d{1,2}.xls"
    S = Dir(ThisWorkbook.Path & "\*.xls")
    N = -1
   
   

    Do While S <> ""
        If UCase(S) Like "*#-*#-*#-[0-9][0-9]*.XLS" Then
            N = N + 1
            ReDim Preserve sz(N)
            sz(N) = S
              If UCase(S) Like "??[0-9]*" Then
                ReDim Preserve SZ2(N)
                SZ2(N) = Mid(S, 3, 1)  
            End If
        End If
        S = Dir
    Loop

    Set matchs = myRegExp.Execute(Join(sz, ","))

    If matchs.Count = 0 Then MsgBox "没有数据文件！", , "提示": GoTo out
    ReDim sz1(2, 0)

    For i = 0 To matchs.Count - 1
        ReDim Preserve sz1(2, i)

        sz1(0, i) = matchs.Item(i)
        sz1(1, i) = Left(Replace(matchs.Item(i), ".xls", ""), Len(Replace(matchs.Item(i), ".xls", "")) - 3) '日期

        sz1(2, i) = Right(Replace(matchs.Item(i), ".xls", ""), 2)   '序号
       ' sz1(2, i) = Left(sz1(2, i), Len(sz1(2, i)) - 4)           '序号
  
    Next i

    Application.ScreenUpdating = False
    Sheet3.Activate
    With Sheet3
        .Columns("A:d").ClearContents
        .[a1].Resize(UBound(sz1, 2) + 1, 3) = Application.Transpose(sz1)
        .[d1].Resize(UBound(SZ2) + 1) = Application.Transpose(SZ2)

        .[a1].CurrentRegion.Sort Key1:=Range("d1"), Order1:=xlAscending, Key2:=Range("b1"), Order2:=xlAscending, key3:=Range("c1"), _
                                 order3:=xlAscending, Header:=xlGuess
        sz1 = Application.Transpose(.Range("A1:A" & .[a1].CurrentRegion.Rows.Count))
        SZ2 = Application.Transpose(.Range("d1:d" & .[d1].CurrentRegion.Rows.Count))

        .Columns("A:d").ClearContents
    End With
    For i = 1 To UBound(sz1)
        For ii = i - 1 To UBound(sz)
            If sz(ii) Like "??" & SZ2(i) & "*" & sz1(i) Then
                temp = sz(i - 1)
                sz(i - 1) = sz(ii)
                sz(ii) = temp
                Exit For
            End If
        Next ii
    Next i

    '数组sz已经排好了序
    Sheet1.Activate
    Columns("A:I").ClearContents
    For i = 0 To UBound(sz)
        With Workbooks.Open(ThisWorkbook.Path & "\" & sz(i))
            For ii = 1 To .Sheets(1).Range("A65536").End(3).Row
                If ThisWorkbook.Sheets(1).Range("A65536").End(3).Row = 1 Then
                    W = 10
                Else
                    W = 2
                End If
                If .Sheets(1).Range("H" & ii) = "" Then .Sheets(1).Rows(ii).Copy ThisWorkbook.Sheets(1).Range("A65536").End(3)(W)
            Next ii
            .Close False
        End With
    Next i
out:
    Application.ScreenUpdating = True
End Sub

[ 本帖最后由 sfadfa 于 2014-11-22 21:29 编辑 ]

Sub Macro1()
    Dim arr, brr, crr(), i As Long, j As Long, k As Long, m As Long, n As Long
    m = xlapp.[b65536].End(xlUp).Row - 5
    arr = xlapp.[b6].Resize(m)
    n = xlapp.[c65536].End(xlUp).Row - 5
    brr = xlapp.[c6].Resize(n, 4)
    ReDim crr(1 To m, 1 To 4)
    For i = 1 To m
        For j = 1 To n
            If brr(j, 1) = arr(i, 1) Then
                For k = 1 To 4
                    crr(i, k) = brr(j, k)
                Next
                Exit For
            End If
        Next
    Next
    xlapp.[c6].Resize(m, 4) = crr
End Sub

Sub Macro1()
    Dim ar, br(), d As Object, i As Long, m As Long, r1 As Long, s As String
    Set d = CreateObject("Scripting.Dictionary")
    r1 = xlapp.[b65536].End(xlUp).Row
    ar = xlapp.Range("e6:u" & r1)
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 1 To UBound(ar)
        s = Trim(ar(i, 1))
        If Not d.Exists(s) Then
            m = m + 1
            d(s) = m
            br(m, 1) = s
            br(m, 2) = 1
            br(m, 3) = ar(i, 13)
        Else
            br(d(s), 2) = br(d(s), 2) + 1
            br(d(s), 3) = br(d(s), 3) + ar(i, 13)
        End If
    Next
    xlapp.Range("a" & r1 + 11).Resize(m, 3) = br
End Sub

Sub Macro1()
    Dim d As Object, dic As Object, rng As Excel.Range, arr, brr(), crr, myfile As String, a, i As Long, j As Long, k As Long, l, m, n, s As String, tmp, artmp
    Set d = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    arr = xlapp.Range("g5:ag" & xlapp.Range("g65536").End(xlUp).Row)
    ReDim brr(1 To UBound(arr), 1 To 3)
    For i = 1 To UBound(arr)
        If Len(arr(i, 13)) Then
            s = "" & arr(i, 1) & "/" & Format(arr(i, 2), "0.00") & "+" & arr(i, 3) & ""
            If Not d.Exists(s) Then
                d(s) = d.Count + 1
                brr(d(s), 1) = s
            End If
            brr(d(s), 2) = brr(d(s), 2) + 1
            dic(s & "|" & arr(i, 13)) = dic(s & "|" & arr(i, 13)) + 1
            k = k + 1: l = l + arr(i, 25): n = n + arr(i, 27)
        End If
        j = j + 1
    Next
    For Each tmp In dic.keys
        artmp = Split(tmp, "|")
        brr(d(artmp(0)), 3) = brr(d(artmp(0)), 3) & "," & dic(tmp) & "|" & artmp(1)
    Next
    s = ""
    For i = 1 To d.Count
        If brr(i, 2) = Val(Mid(brr(i, 3), 2)) Then
            s = s & "；" & brr(i, 2) & "|" & brr(i, 1) & Split(brr(i, 3), "|")(1)
        Else
            s = s & "；" & brr(i, 2) & "|" & brr(i, 1) & ":" & Mid(brr(i, 3), 2)
        End If
    Next
    a = Mid(Replace(s, "|", ""), 2)
    d.RemoveAll
    crr = xlapp.Range("AA5:AA" & xlapp.Range("g65536").End(xlUp).Row)
    For i = 1 To UBound(crr)
        If Len(crr(i, 1)) Then d(crr(i, 1)) = ""
    Next
    m = Join(d.keys, "/")
    xlapp.DisplayAlerts = False
    myfile = Dir(xlapp.ActiveWorkbook.Path & "\*.xls")
    xlapp.Workbooks.Open FileName:=xlapp.ActiveWorkbook.Path & "\" & myfile
    On Error Resume Next
    Set rng = xlapp.InputBox("请选择：", , "$E$20", Type:=8)
    xlapp.Range(rng.Address) = IIf(Len(a) > 0, a & "；" & Format(l, "0.00") & "。", "")
    xlapp.Range(rng.Address).Offset(, -2) = j
    xlapp.Range(rng.Address).Offset(, -1) = k
    xlapp.Range(rng.Address).Offset(, 1) = l
    xlapp.Range(rng.Address).Offset(, 2) = m
    xlapp.Range(rng.Address).Offset(, 3) = n
    xlapp.DisplayAlerts = True
End Sub

[ 本帖最后由 sfadfa 于 2014-11-22 20:47 编辑 ]

'以下原始统计，对G、H、I列进行计数并写入数组brr中，字典d记下各值位于brr的哪一行，字典dic统计G、H、I、M列进行计数
     For i% = 1 To UBound(arr)
         If Len(arr(i, 7)) Then
            s$ = "(" & arr(i, 1) & "-" & arr(i, 2) & "-" & arr(i, 3) & ")"
            If Not d.exists(s) Then
               d(s) = d.Count + 1  '等效于m=m+1 d(s) =m 两行（m要初始化为0），用于记录下新值s出现的先后顺序1、2、3……
               brr(d(s), 1) = s    '新值s出现的先后顺序依次将s写进数组brr，即brr（1，1）、brr（2，1）、brr（3，1）……
           End If
            brr(d(s), 2) = brr(d(s), 2) + 1   '按s出现的次数依次累加1，即统计s出现了多少次写进数组brr，即brr（1，2）、brr（2，2）、brr（3，2）……
            dic(s & "|" & arr(i, 7)) = dic(s & "|" & arr(i, 7)) + 1   '同上，只是统计的是s & "|" & arr(i, 7)出现了多少次写进字典dic中
        End If
      Next
      '原始统计完成。
     '以下将G、H、I列相同时，M列出现了些什么、出现几次写入数组brr
      For Each tmp In dic.keys   '具体实现过程按f8看本地窗口中artmp和brr的内容变化
          artmp = Split(tmp, "|")    '字典dic的key记录的是s & "|" & arr(i, 7)，现在将他们分开成s与arr(i, 7)写进临时数组artmp中，artmp（0）为s,artmp(1)为arr(i, 7)
          brr(d(artmp(0)), 3) = brr(d(artmp(0)), 3) & "," & dic(tmp) & "个" & artmp(1)  '依据s将arr(i,7)及其出现次数对应写入数组brr中
     Next
      '统计全部完成
     '以下处理统计结果，为输出做准备
     s = ""
      For i = 1 To d.Count
          s = s & ";" & brr(i, 2) & "个" & brr(i, 1) & ":" & Mid(brr(i, 3), 2)  '把brr中的内容串成一串，具体按f8看本地窗口中brr的内容与s的变化过程
     Next
      '输出结果：
     MsgBox Mid(s, 2)

Sub Macro1()
    Dim j As Long, k As Long, m As Long, sfirst, kmax
    xlapp.ScreenUpdating = False
    k = 行 - 1
    m = Mid(xlapp.Range("e65536").End(xlUp), 5, 5)
    j = 0
    m = m + 1
    sfirst = Left(xlapp.Range("e65536").End(xlUp), 4)
    kmax = xlapp.Range("f65536").End(xlUp).Row
    x = xlapp.Range("a65536").End(xlUp)
    Do
        j = j + 1
        If j > 3 Then
            m = m + 1
            j = 1
        End If
        k = k + 1
        If k > kmax Then Exit Sub
        y = y + 1
        xlapp.Cells(k, 1) = x + y
        xlapp.Cells(k, 2) = xlapp.Range("b65536").End(xlUp)
        xlapp.Cells(k, 3) = xlapp.Range("c65536").End(xlUp)
        xlapp.Cells(k, 4) = xlapp.Range("d65536").End(xlUp)
        xlapp.Cells(k, 5) = sfirst & Format(m, "00000") & j
    Loop While True
    xlapp.ScreenUpdating = True
End Sub