两列不完全一致数据对比，不同自动插入空白行

manzoneut

lsdongjh 发表于 2017-7-6 15:43
代码中没有考虑 很多细节，如：没有数据。用你上传的示例测试正常，请上传出错的文件

不好意思，刚才出错是我的问题。增加批量数据后测试没有问题，只是数据排序顺序有点不同，但是数据是正确的，太感谢了

manzoneut

chxw68 发表于 2017-7-6 16:03

添加大批量数据测试后没问题，只是项目排序顺序有点不同，数据是正确的，感谢大师

chxw68

不知道你是按什么排序的？

qingc0221

1. Sub 插入空白行()
   
2.     Dim LastRow As Long
   
3.     Dim i As Integer, j As Integer, k As Integer, n As Integer
   
4.     Dim Arr, Result()
   
5.     LastRow = Range("A1").CurrentRegion.Rows.Count
   
6.     Arr = Range("A3:G" & LastRow)
   
7.     n = LastRow - 2
   
8.     ReDim Result(1 To 2 * n, 1 To 7)
   
9.     i = 1: j = 1
   
10.     On Error Resume Next
    
11.     Do
    
12.         k = k + 1
    
13.         If Arr(i, 1) = Arr(j, 5) Then
    
14.             Result(k, 1) = Arr(i, 1): Result(k, 2) = Arr(i, 2): Result(k, 3) = Arr(i, 3)
    
15.             Result(k, 5) = Arr(j, 5): Result(k, 6) = Arr(j, 6): Result(k, 7) = Arr(j, 7)
    
16.             i = i + 1: j = j + 1
    
17.         ElseIf Arr(i, 1) < Arr(j, 5) Or j > n Then
    
18.             Result(k, 1) = Arr(i, 1): Result(k, 2) = Arr(i, 2): Result(k, 3) = Arr(i, 3)
    
19.             i = i + 1
    
20.         ElseIf Arr(i, 1) > Arr(j, 5) Or i > n Then
    
21.             Result(k, 5) = Arr(j, 5): Result(k, 6) = Arr(j, 6): Result(k, 7) = Arr(j, 7)
    
22.             j = j + 1
    
23.         End If
    
24.     Loop Until i > n And j > n
    
25.     Range("A3").Resize(k, 7) = Result
    
26.     Range("A3").CurrentRegion.Borders.Weight = xlThin
    
27. End Sub

复制代码

manzoneut

chxw68 发表于 2017-7-6 17:05
不知道你是按什么排序的？

就是按项目名称升序排列，比对前A,E两列已经按升序排列好了，出结果后某些行会出现不按升序排列的情况

chxw68

主要原因是你两列项目不完全一致。

manzoneut

qingc0221 发表于 2017-7-6 17:09

谢谢帮忙。有点小问题，加入批量数据执行后中间有部分行不会按项目号对齐

manzoneut

chxw68 发表于 2017-7-7 17:25
主要原因是你两列项目不完全一致。

是的，不过这没有什么影响，效果已经达到了。感谢
还有就是如果我要对比的数据要加多几列改哪个参数？比如我现在对比的两个项目每边只有3列，我要是有7列的话改哪个参数呢？VBA刚接触，代码都不熟悉，工作又比较急用，麻烦大师了。

chxw68

manzoneut 发表于 2017-7-7 18:01
是的，不过这没有什么影响，效果已经达到了。感谢
还有就是如果我要对比的数据要加多几列改哪个参数？比 ...

改动内容比较多。