批量进行Excel之间的数据拷贝

Sub MappingKey(dic As Object, ws As Worksheet)
   
    Dim r  As Range
    Set r = ws.Range("E3")
    Dim key As String
    Dim val As String
    Dim arr()
   
    While r.Value <> ""
        val = r.Value
        If EndWith(r.Value, ".xls") Then val = left(r.Value, Len(r.Value) - 4)
        'key = Cells(r.row, "C").Value & "." & val
        key = val
        If dic.exists(key) Then
            arr = dic.Item(key)
           
            ws.Cells(r.row, "R").Value = arr(1)
            ws.Cells(r.row, "S").Value = arr(2)
            ws.Cells(r.row, "T").Value = arr(0)
            ws.Cells(r.row, "U").Value = arr(3)
            ws.Cells(r.row, "V").Value = arr(4)
            ws.Cells(r.row, "W").Value = arr(0)
        End If
        Set r = r.Offset(1)
    Wend
   
End Sub

Sub BatchMapping(dic As Object)
     Dim r As Range
     Set r = Workbooks("tools.xls").Worksheets("Prop").Range("B2")
     Application.DisplayAlerts = False
    
     While r.Value <> ""
        Dim wb As Workbook
        Dim ws As Worksheet
        Set wb = Application.Workbooks.Open(Filename:=r.Value, ReadOnly:=False, UpdateLinks:=0)
        Set ws = wb.Sheets(1)
        MappingKey dic, ws
        wb.Close SaveChanges:=True
       
        Set r = r.Offset(1)
     Wend
    
     Application.DisplayAlerts = True

     MsgBox "Over..."
   
End Sub

Sub LoadDic(dic As Object)
   
     Dim r As Range
     Set r = Workbooks("tools.xls").Worksheets("Prop").Range("A2")
     Application.DisplayAlerts = False
     While r.Value <> ""
        Dim wb As Workbook
        Dim ws As Worksheet
        Set wb = Application.Workbooks.Open(Filename:=r.Value, ReadOnly:=True, UpdateLinks:=0)
        Set ws = wb.Sheets(1)
       
        Dim r1 As Range
        Set r1 = ws.Range("E5")
        Dim key As String
        Dim val As String
        Dim val2 As String
        Dim msg As String
        msg = ""
       
        While r1.Value <> ""
            val2 = r1.Value
            If EndWith(r1.Value, ".xls") Then val2 = left(r1.Value, Len(r1.Value) - 4)
           
            'key = ws.Cells(r1.row, "C").Value & "." & val2
            key = val2
            Dim arr()
           
            arr = Array(ws.Cells(r1.row, "I").Value, ws.Cells(r1.row, "AK").Value, ws.Cells(r1.row, "AL").Value, ws.Cells(r1.row, "AZ").Value, ws.Cells(r1.row, "BA").Value)
           
            If Not dic.exists(key) Then
                dic.Add key, arr
            Else
                msg = msg & key & vbNewLine
            End If
           
            Set r1 = r1.Offset(1)
        Wend
   
        wb.Close SaveChanges:=False
       
        Set r = r.Offset(1)
     Wend
     Application.DisplayAlerts = True
     Debug.Print dic.count & ""
     Debug.Print msg
    
End Sub

'入口方法

Sub Exec()
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
   
    LoadDic dic
   
    BatchMapping dic
   
End Sub