2

我真的不知道如何清楚地解释这一点。请看附图

在此处输入图像描述

我有一个包含 4 个不同列的表，其中 2 个列彼此相同（名称和数量）。目标是比较数量之间的差异，但是，为了做到这一点。我必须： 1. 对数据进行排序 2. 逐项匹配数据 这对小表来说没什么大不了的，但有一万行，我需要几天时间才能完成。

请帮助我，我很感激。

我的逻辑是： 1. 对前两列（名称和数量）进行排序 2. 对于后两列（名称和数量）的每个值，检查它是否与前两列匹配。如果为真，则插入该值。3.对于不匹配的值，插入新行，偏移量与前两列但不在后两列的行

4

2 回答 2

2

这是你正在尝试的吗？

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, newRow As Long
    Dim aCell As Range, SrchRange As Range

    Set ws = Sheets("Sheet1")

    With ws
        .Columns("A:B").Copy .Columns("G:G")
        .Columns("G:H").Sort Key1:=.Range("G2"), Order1:=xlAscending, Header:=xlYes, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
          DataOption1:=xlSortNormal

        lastRow = .Range("G" & Rows.Count).End(xlUp).Row
        newRow = lastRow

        Set SrchRange = .Range("G2:G" & lastRow)

        lastRow = .Range("C" & Rows.Count).End(xlUp).Row

        .Range("I1").Value = "NAME": .Range("J1").Value = "QTY"

        For i = 2 To lastRow
            If Len(Trim(.Range("C" & i).Value)) <> 0 Then
                Set aCell = SrchRange.Find(What:=.Range("C" & i).Value, LookIn:=xlFormulas, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

                If Not aCell Is Nothing Then
                    .Range("I" & aCell.Row).Value = .Range("C" & i).Value
                    .Range("J" & aCell.Row).Value = .Range("D" & i).Value
                Else
                    newRow = newRow + 1
                    .Range("I" & newRow).Value = .Range("C" & i).Value
                    .Range("J" & newRow).Value = .Range("D" & i).Value
                End If
            End If
        Next
    End With
End Sub

快照

在此处输入图像描述

于 2012-05-02T22:35:10.017 回答
1

在此处输入图像描述

根据您的上述要求，逻辑完全改变，因此我将其发布为不同的答案。

同样在您上面的“ This is Wonderful ”快照中，有一个小错误。按逻辑SAMPLE10不能上来SAMPLE11。它必须紧随其后SAMPLE11。

请参阅下面的快照

在此处输入图像描述

这是代码:)

Option Explicit

Sub sAMPLE()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, newRow As Long, rw As Long
    Dim aCell As Range, SrchRange As Range

    Set ws = Sheets("Sheet1")

    With ws
        .Columns("A:B").Copy .Columns("G:G")
         .Columns("G:H").Sort key1:=.Range("G2"), Order1:=xlAscending, Header:=xlYes, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
          DataOption1:=xlSortNormal

        .Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

         lastRow = .Range("G" & Rows.Count).End(xlUp).Row

         For i = 2 To lastRow
            .Range("H" & i).Value = GetLastNumbers(.Range("G" & i).Value)

            If .Range("H" & i).Value <> 0 Then
                .Range("G" & i).Value = Left(.Range("G" & i).Value, _
                Len(.Range("G" & i).Value) - Len(.Range("H" & i).Value))
            End If
         Next i

        .Columns("G:H").Sort key1:=.Range("H2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

        For i = 2 To lastRow
            If .Range("H" & i).Value <> 0 Then _
            .Range("G" & i).Value = .Range("G" & i).Value & .Range("H" & i).Value
        Next i

        .Columns("H:H").Delete

        newRow = lastRow

        Set SrchRange = .Range("G2:G" & lastRow)

        lastRow = .Range("C" & Rows.Count).End(xlUp).Row

        .Range("I1").Value = "NAME": .Range("J1").Value = "QTY"

        For i = 2 To lastRow
            If Len(Trim(.Range("C" & i).Value)) <> 0 Then
                Set aCell = SrchRange.Find(What:=.Range("C" & i).Value, LookIn:=xlFormulas, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

                If Not aCell Is Nothing Then
                    .Range("I" & aCell.Row).Value = .Range("C" & i).Value
                    .Range("J" & aCell.Row).Value = Application.Evaluate("=SUMPRODUCT((C2:C" & lastRow _
                            & "=" & """" & .Range("C" & i).Value & """" & ")*(D2:D" & lastRow & "))")
                Else
                    newRow = newRow + 1
                    .Range("I" & newRow).Value = .Range("C" & i).Value
                    .Range("J" & newRow).Value = .Range("D" & i).Value
                End If
            End If
        Next
        lastRow = .Range("G" & Rows.Count).End(xlUp).Row
        For i = lastRow To 2 Step -1
            If .Range("G" & i).Value = .Range("G" & i - 1).Value Then
                .Range("H" & i - 1).Value = .Range("H" & i).Value + .Range("H" & i - 1).Value
                If Application.WorksheetFunction.CountA(.Range("I" & i & ":J" & i)) = 0 Then
                    .Range("G" & i & ":J" & i).Delete Shift:=xlUp
                Else
                    .Range("G" & i & ":H" & i).Delete Shift:=xlUp
                End If
            End If
        Next i

        lastRow = .Range("I" & Rows.Count).End(xlUp).Row
        newRow = .Range("G" & Rows.Count).End(xlUp).Row

        If lastRow <= newRow Then Exit Sub

        .Range("I" & newRow & ":J" & lastRow).Sort key1:=.Range("I" & newRow), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

        For i = lastRow To newRow Step -1
            If .Range("I" & i).Value = .Range("I" & i - 1).Value Then
                .Range("J" & i - 1).Value = .Range("J" & i).Value + .Range("J" & i - 1).Value
                .Range("I" & i & ":J" & i).Delete Shift:=xlUp
            End If
        Next i
    End With
End Sub

Function GetLastNumbers(strVal As String) As Long
    Dim j As Long, strTemp As String

    For j = Len(strVal) To 1 Step -1
        If Not IsNumeric(Mid(strVal, j, 1)) Then Exit For
        strTemp = Mid(strVal, j, 1) & strTemp
    Next j
    GetLastNumbers = Val(Trim(strTemp))
End Function
于 2012-05-31T03:02:56.210 回答