复制黄色区域数据（两列）到另一个sheet

ziran-juan

yangyangzhifeng 老师帮我写了一个代码，当时我没有考虑到后面的工作还有那么的繁琐和不好操作，
特另起一贴，希望再次得到老师们的帮忙！

数据的检查代码已经写好了，颜色高亮黄色。高亮红色部分是错误数据，不需要复制。
现在需要把高亮黄色部分（Sheet2的B、C列）全部复制到sheet1的B、C列；

Sheet1A列的序号也自动添加，
这个代码我试着自己写了一下，现在才100多行的计算时间就花了近2秒，不明白是什么原因，还请懂的老师们指点优化！

把黄色区域复制好后，我希望sheet1的数据B列到最后有数据的一列，按B列排序。
因为列数在不断增加，怎么判断最后一列的位置，然后让B列到最后一列按B列Key排序呢？

算是对yangyangzhifeng 老师代码的一个补充吧，希望老师直接在Sub 检查（）后面直接添加代码，也希望yangyangzhifeng 老师不介意。
多谢了！

AVEL

1. 
   
2. Sub 检查()
   
3.     Dim d As Object, i&
   
4.     Dim ar, br, rng2 As Range, rng3 As Range
   
5.     ar = Sheet1.Range("b1:c" & Sheet1.Range("b65536").End(xlUp).Row)
   
6.     br = Sheet2.Range("b1:c" & Sheet2.Range("b65536").End(xlUp).Row)
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     For i = 7 To UBound(ar)
   
9.         d(ar(i, 2)) = ar(i, 1)
   
10.         d(ar(i, 1)) = ar(i, 2)
    
11.     Next
    
12.     For i = 3 To UBound(br)
    
13.         If Not d.exists(br(i, 1)) And Not d.exists(br(i, 2)) Then
    
14.             If rng2 Is Nothing Then Set rng2 = Sheet2.Range("b" & i & ":c" & i) Else Set rng2 = Union(rng2, Sheet2.Range("b" & i & ":c" & i))
    
15.         Else
    
16.             If br(i, 1) <> d(br(i, 2)) Or br(i, 2) <> d(br(i, 1)) Then
    
17.                 If rng3 Is Nothing Then Set rng3 = Sheet2.Range("b" & i & ":c" & i) Else Set rng3 = Union(rng3, Sheet2.Range("b" & i & ":c" & i))
    
18.             End If
    
19.         End If
    
20.     Next
    
21.     Sheet2.Cells.Interior.ColorIndex = xlNone
    
22.     If Not rng3 Is Nothing Then rng3.Interior.Color = vbRed
    
23.     If Not rng2 Is Nothing Then rng2.Interior.Color = vbYellow
    
24.     '    For i = 7 To Sheet1.Range("b56565").End(3).Row
    
25.     '        If Sheet1.Cells(i, 2) <> "" Then Sheet1.Cells(i, 1) = i - 6
    
26.     '    Next
    
27.     If rng2 Is Nothing Then Exit Sub
    
28.     With Sheet1
    
29.         Dim rng As Range
    
30.         rng2.Copy .[b65536].End(3).Offset(1)
    
31.         Set rng = .[a65536].End(3).Offset(1).Resize(.[b65536].End(3).Row - .[a65536].End(3).Row)
    
32.         rng.Formula = "=row()-6"
    
33.         rng.Value = rng.Value
    
34.     End With
    
35. End Sub

复制代码

改写了一下

AVEL

    '    For i = 7 To Sheet1.Range("b56565").End(3).Row

    '        If Sheet1.Cells(i, 2) <> "" Then Sheet1.Cells(i, 1) = i - 6

    '    Next
=====================
这一段是你修改以后代码时间长的罪魁祸首