Excel不同工作簿之间提取信息

Sub 不同工作簿间提取信息() '用于单个字段信息的提取；
Dim w As Workbook, wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim sh As Worksheet, sh1 As Worksheet, sh2 As Worksheet, ce As Range, shp As Shape
Dim dic As Object, re As Object
Dim arr, brr, crr '若带()则默认为一维数组；
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
' Set wb1 = ActiveWorkbook
' Set sh = ActiveSheet
关键词A = "教师信息"
关键词B = "学生信息"
关键词C = "中期检查"

m = 0
For Each w In Workbooks
If InStr(w.Name, 关键词A) > 0 Then
Set wb1 = Workbooks(w.Name)
m = m + 1
ElseIf InStr(w.Name, 关键词B) > 0 Then
Set wb2 = Workbooks(w.Name)
m = m + 1
ElseIf InStr(w.Name, 关键词C) > 0 Then
Set wb3 = Workbooks(w.Name)
m = m + 1
End If
If m = 3 Then Exit For 'm还可设置3或更多；
Next
Set sh1 = wb1.Sheets(1)
For i = 2 To wb1.Sheets(1).Range("D65536").End(3).Row '对应关键词A
If Not dic1.exists(Trim(sh1.Range("C" & i).Value)) Then dic1.Add Trim(sh1.Range("C" & i).Value), Trim(sh1.Range("D" & i).Value)
Next
Set sh2 = wb2.Sheets(1)
For i = 2 To sh2.Range("H65536").End(3).Row '对应关键词B
sh2.Range("J" & i).Value = dic1(Trim(sh2.Range("H" & i).Value))
Next

MsgBox "已完成！!!", vbOKCancel, "程序处理"

End Sub

Sub 多字段工作簿间提取信息() '利用数组来实现赋值；
Dim w As Workbook, wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim sh As Worksheet, sh1 As Worksheet, sh2 As Worksheet, ce As Range, shp As Shape
Dim dic As Object, re As Object
Dim arr, brr, crr '若带()则默认为一维数组；
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
' Set wb1 = ActiveWorkbook
' Set sh = ActiveSheet
关键词A = "姓名汇总"
关键词B = "学生信息"
关键词C = "中期检查"

m = 0
For Each w In Workbooks
If InStr(w.Name, 关键词A) > 0 Then
Set wb1 = Workbooks(w.Name)
m = m + 1
ElseIf InStr(w.Name, 关键词B) > 0 Then
Set wb2 = Workbooks(w.Name)
m = m + 1
ElseIf InStr(w.Name, 关键词C) > 0 Then
Set wb3 = Workbooks(w.Name)
m = m + 1
End If
If m = 3 Then Exit For 'm还可设置3或更多；
Next
Set sh1 = wb1.Sheets(1)
arr = sh1.UsedRange
For i = 2 To wb1.Sheets(1).Range("B65536").End(3).Row '对应关键词A
If Not dic1.exists(Trim(arr(i, 2))) Then dic1.Add Trim(arr(i, 2)), i '行号
'If Not dic1.exists(Trim(sh1.Range("B" & i).Value)) Then dic1.Add Trim(sh1.Range("B" & i).Value), sh1.Range("D" & i).Row '行号
Next
Set sh2 = wb2.Sheets(1)
For i = 2 To sh2.Range("H65536").End(3).Row '对应关键词B
ro = dic1(Trim(sh2.Range("D" & i).Value))
If sh2.Range("C" & i).Value = "" Then
sh2.Range("C" & i).Value = arr(ro, 1) '这里也容易出错,不使用Value会导致出问题；无法赋值；
ElseIf CStr(sh2.Range("C" & i).Value) <> CStr(arr(ro, 1)) Then '这里就容易出问题。不用Cstr会导致字符串和数字不等；
MsgBox "错误！!!" & arr(ro, 2) & "学号不匹配！!!"
End If
sh2.Range("i" & i).Value = arr(ro, 3)
Next

MsgBox "已完成！!!", vbOKCancel, "程序处理"

End Sub