数据处理，高手请进！

vincent.cn

出错的原因可能是我这里没考虑周全，红字部分的2种数据情况未考虑到，现增加进去了。

zhaogang1960

1、9楼附件代码还是原来的
2、原来附件中的标志底色不见了，这就导致了程序无法判断哪个保留，哪个该放到最后
3、一行只有256个单元格，请检查附件中1——28行的非空单元格数，已经达到了681个，使用2007吧

vincent.cn

晕，原来是这样啊，标志底色是我标出来为了让您看得更清楚，平时导入数据后都是没有底色，就没有更好的解决办法了吗

zhaogang1960

代码处理需要条件，你给出的红色单元格似乎有点规律，就是含有小数点，第一列好像是去掉重复值，第二列也说得过去，就是长度大于或等于9的数字，但有一些没有规律，如：你保留了12597，却放弃了1496
256个单元格可以转置成列，但是列数还是不能超过256

vincent.cn

1、第一列去掉的规律是如果此组数据有2行，就去掉此组数据第二行的第一列数值（判断一组数据是否有2行，主要看第二列数值，如612091035     61209103510。后面多个10的为此组数据有2行，没有的就是1行了。）
2、3‘开头的全部去除。
3、与第二列类似612091035（即后面不带10的数值），跟它同行的第四列数值都移到最后。
规律是这样的，有办法不标颜色就实现吗

vincent.cn

4、与第二列类似612091035（即后面不带10的数值），跟它同行的5、6、7列去除。
这样规律就齐了。

vincent.cn

你再看看这个，应该就不用底色来区分了吧。

vincent.cn

谢谢你好耐心地教我！zhaogang1960老师

zhaogang1960

请测试：
Sub Macro1()
    Dim rng As Range, brr, crr, arr(), ary(), drr(), c As Range
    Dim i As Long, lr As Long, lc As Integer, m As Integer, ii As Integer, j As Integer
    With Sheet1
        lr = .Range("a65536").End(xlUp).Row
        lc = .UsedRange.Columns.Count
        brr = .Range("a1").Resize(lr + 1, lc)
        crr = .UsedRange
    End With
    n = 1
    ReDim ary(1 To n)
    ary(1) = 1
    For i = 2 To lr + 1
        If brr(i, 1) <> brr(i - 1, 1) Then
            n = n + 1
            ReDim Preserve ary(1 To n)
            ary(n) = i
        End If
    Next
    ReDim drr(1 To n - 1)
    For i = 1 To lr
        If i > 1 Then
            If brr(i, 1) = brr(i - 1, 1) Then brr(i, 1) = ""
        End If
        If Right(brr(i, 2), 2) <> "10" Then
            m = m + 1
            drr(m) = brr(i, 4)
            For j = 4 To 7
                brr(i, j) = ""
            Next
        End If
        For j = 8 To lc
            If InStr(brr(i, j), "'") Then brr(i, j) = ""
        Next
        brr(i, 2) = ""
    Next
    Application.ScreenUpdating = False
    With Sheet1
        .Range("a1").Resize(lr + 1, lc) = brr
        Sheet2.UsedRange.ClearContents
        For i = 1 To n - 1
            brr = .Cells(ary(i), 1).Resize(ary(i + 1) - ary(i), lc)
            m = 0
            For ii = 1 To UBound(brr)
                For j = 1 To lc
                    If brr(ii, j) <> "" Then
                        m = m + 1
                        ReDim Preserve arr(1 To m)
                        arr(m) = brr(ii, j)
                    End If
                Next
            Next
            m = m + 1
            ReDim Preserve arr(1 To m)
            arr(m) = drr(i)
            Sheet2.Cells(i, 1).Resize(1, m) = arr
            Erase arr
        Next
        .UsedRange.ClearContents
        .Cells.Resize(lr, lc) = crr
    End With
    Application.ScreenUpdating = True
End Sub

vincent.cn

现在唯一存在的问题是：当两组及两组以上的数据，其A列单元格的数值一样时，出现“下标错误”。