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

 

转载于:https://www.cnblogs.com/zhanglei1371/p/6662318.html

  • 0
    点赞
  • 0
    收藏
    觉得还不错? 一键收藏
  • 0
    评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值