[已解决]两张工作合并

清风竹影203 · 发表于 2017-8-21 18:21

本帖最后由清风竹影203 于 2017-8-24 18:22 编辑

求助高手，将SHEET2中的数据，按池号和对应的表头在SHEET1中更改，谢谢了！

最佳答案

月排行榜 / 总排行榜

frankzhang21

2017-8-23 17:33

清风竹影203 发表于 2017-8-23 16:59
老师您好！经过昨天的测试，基本上能解决问题了，只是还有一个小毛病想请老师帮帮我，就是如何让sheet2中 ...

Public Sub update()
Dim arr(), brr(), crr(), d, i, k, n
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a2:ar" & Sheet1.Range("a65536").End(3).Row) '有多少列就修改这行的ar所对应的那个最后列名，最后一列比如是as就ar修改成as，
brr = Sheet2.Range("a2:ar" & Sheet2.Range("a65536").End(3).Row) '同上
ReDim crr(1 To UBound(brr, 2) - 1)
For i = 1 To UBound(brr, 1) 'sheet2写入字典
For n = 1 To (UBound(brr, 2) - 1) '装入字典的item数组
crr(n) = brr(i, n + 1)
Next n
d(brr(i, 1)) = crr '写入字典
ReDim crr(1 To UBound(brr, 2) - 1) '清空数组
Next i
For k = 1 To UBound(arr, 1) '更新数组
If d.exists(arr(k, 1)) Then
For n = 1 To (UBound(brr, 2) - 1)
If Not VBA.IsEmpty(d(arr(k, 1))(n)) Then ' 添加判断，空值不写入数组
arr(k, n + 1) = d(arr(k, 1))(n)
End If
Next n
End If
Next k
Sheet1.[a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr '写入
End Sub

复制代码

应该可以了

跳转到最佳答案楼层

frankzhang21 · 发表于 2017-8-21 18:57

不知道池号是不是唯一的，按池号做了个

Public Sub update()
Dim arr(), brr(), d, i, k
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a2:d" & Sheet1.Range("d65536").End(3).Row)
brr = Sheet2.Range("a2:d" & Sheet2.Range("d65536").End(3).Row)
For i = 1 To UBound(brr, 1) 'sheet2写入字典
d(brr(i, 1)) = Array(brr(i, 2), brr(i, 3), brr(i, 4))
Next
For k = 1 To UBound(arr, 1) '更新数组
If d.exists(arr(k, 1)) Then
arr(k, 2) = d(arr(k, 1))(0)
arr(k, 3) = d(arr(k, 1))(1)
arr(k, 4) = d(arr(k, 1))(2)
End If
Next
Sheet1.[a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr '写入
End Sub

复制代码

frankzhang21 · 发表于 2017-8-21 18:59

附件如下

清风竹影203 · 发表于 2017-8-21 21:16

frankzhang21 发表于 2017-8-21 18:59
附件如下

谢谢老师的帮助，问题已经部分解决，池号是唯一的，还有就是SHEET1中的数据其实非常庞大，吨位后面还有四十几项的有关数据，池号更是有五千多个，都是唯一的，不会有重复编号的情况。sheet2中每天只有部分池号后面的数据更新，逐一填写非常麻烦，并且容易出错，还请老师能够彻底解决我的困扰。详见附件
再次表示感谢！

frankzhang21 · 发表于 2017-8-21 23:00

清风竹影203 发表于 2017-8-21 21:16
谢谢老师的帮助，问题已经部分解决，池号是唯一的，还有就是SHEET1中的数据其实非常庞大，吨位后面还有四 ...

改好了，可以支持很多列了

sheet1,sheet2结构要完全一样。比如列的顺序，第一行都是标题什么的

给你写好注释了，修改很容易

清风竹影203 · 发表于 2017-8-23 16:59

frankzhang21 发表于 2017-8-21 23:00
改好了，可以支持很多列了

sheet1,sheet2结构要完全一样。比如列的顺序，第一行都是标题什么的

老师您好！经过昨天的测试，基本上能解决问题了，只是还有一个小毛病想请老师帮帮我，就是如何让sheet2中的空格不影响sheet1中不需要更新的那些数据，因为sheet2中，没有变动的数据都是空格。（详见附件）
对您的帮助，再次表示感谢！

frankzhang21 · 发表于 2017-8-23 17:33

这个最佳答案由 frankzhang21 给出，感谢 frankzhang21 的回答。

单击隐藏图章

清风竹影203 发表于 2017-8-23 16:59
老师您好！经过昨天的测试，基本上能解决问题了，只是还有一个小毛病想请老师帮帮我，就是如何让sheet2中 ...

Public Sub update()
Dim arr(), brr(), crr(), d, i, k, n
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a2:ar" & Sheet1.Range("a65536").End(3).Row) '有多少列就修改这行的ar所对应的那个最后列名，最后一列比如是as就ar修改成as，
brr = Sheet2.Range("a2:ar" & Sheet2.Range("a65536").End(3).Row) '同上
ReDim crr(1 To UBound(brr, 2) - 1)
For i = 1 To UBound(brr, 1) 'sheet2写入字典
For n = 1 To (UBound(brr, 2) - 1) '装入字典的item数组
crr(n) = brr(i, n + 1)
Next n
d(brr(i, 1)) = crr '写入字典
ReDim crr(1 To UBound(brr, 2) - 1) '清空数组
Next i
For k = 1 To UBound(arr, 1) '更新数组
If d.exists(arr(k, 1)) Then
For n = 1 To (UBound(brr, 2) - 1)
If Not VBA.IsEmpty(d(arr(k, 1))(n)) Then ' 添加判断，空值不写入数组
arr(k, n + 1) = d(arr(k, 1))(n)
End If
Next n
End If
Next k
Sheet1.[a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr '写入
End Sub

复制代码

应该可以了

清风竹影203 · 发表于 2017-8-24 18:21

今天测试过后，没有问题，谢谢老师，以后再遇到难题还望您不吝赐教哦！

清风竹影203 · 发表于 2017-12-17 14:13

frankzhang21 发表于 2017-8-23 17:33
应该可以了

老师您好，非常感谢上次您对我的帮助，今天还要麻烦您一下，还是这张表，就是如何才能让sheet1中更改过的数据显示红色，目的是为了让发生变动后的数据更加醒目。

frankzhang21 · 发表于 2018-7-7 10:11

清风竹影203 发表于 2017-12-17 14:13
老师您好，非常感谢上次您对我的帮助，今天还要麻烦您一下，还是这张表，就是如何才能让sheet1中更改过的 ...

哈哈半年多了，不知道你的问题解决了没有。

好久没写VBA了，现在都用R了

		自动登录	找回密码
密码			注册