0

私の質問はVBA Excelです。これに似たデータセットがあります: (編集済み)

Order Number Description                    Item Code    Value
AA000001     Mopping Service Payment    00001            100.00
AA000001     Mopping Service Discount   00001            -50.00
AA000001     Bucket Rental                  00002             50.00
AA000001     Bucket Rental Discount     00002            -25.00
AA000001     Mopping Service Payment        00001             25.00
AA000001     Bucket Rental                  00002             10.00
AA000002     Mopping Service Payment    00001            100.00
AA000002     Mopping Service Discount   00001            -50.00
AA000002     Bucket Rental                  00002             50.00
AA000002     Bucket Rental Discount     00002            -25.00

私が出力したいもの：

Order Number Description                    Item Code    Value
AA000001     Mopping Service Payment    00001             75.00
AA000001     Bucket Rental                  00002             35.00
AA000002     Mopping Service Payment    00001             50.00
AA000002     Bucket Rental                  00002             25.00

インターウェブで次のコードを見つけ、少し修正しましたが、注文番号に基づいて重複を結合するためのロジックがありません (代わりに、注文に関係なくすべてのアイテム コードを同じ値に置き換えています)。 Number.) コードを追加して、特定の注文番号に類似するすべてのアイテム コードを取得し、それらを合計する方法はありますか?

何を追加する必要がありますか? 私は何が欠けていますか？前もって感謝します！

    Dim Sh As Worksheet
    Dim LastRow As Long 
    Dim Rng As Range
    Set Sh = Worksheets(1)
    Sh.Columns(5).Insert
    LastRow = Sh.Range("A65536").End(xlUp).Row
    With Sh.Range("A1:A" & LastRow).Offset(0, 4)
        .FormulaR1C1 = "=IF(COUNTIF(R1C[-2]:RC[-2],RC[-2])>1,"""",SUMIF(R1C[-2]:R[" & LastRow & "]C[-2],RC[-2],R1C[-1]:R[" & LastRow & "]C[-1]))"
        .Value = .Value
    End With
    Sh.Columns(4).Delete
    Sh.Rows(1).Insert
    Set Rng = Sh.Range("D1:D" & LastRow + 1)
    With Rng
        .AutoFilter Field:=1, Criteria1:="="
        .SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With
4

1 に答える 1

0

このコードは、注文番号と製品コードの文字列を組み合わせて商品を照合し、計算を行い、割引を含む行を削除します。それがあなたのために働くことを願っています

Option Explicit

Sub Combine__And__Delete()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws As Worksheet
    Set ws = Sheets(1)

    Dim i&, j&, lr&, rng As Range, nrng As Range, str$, com$, x#, y#
    lr = ws.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lr
        Set rng = ws.Range("A" & i): str = rng.Text & rng.Offset(0, 2).Text
        For j = 2 To lr
            If i <> j Then
                Set nrng = ws.Range("A" & j): com = nrng.Text & nrng.Offset(0, 2).Text
                If StrComp(str, com, 1) = 0 Then
                    x = CDbl(rng.Offset(0, 3)): y = CDbl(nrng.Offset(0, 3))
                    If y < 0 Then
                        rng.Offset(0, 4) = CDbl(rng.Offset(0, 3)) - Abs(CDbl(nrng.Offset(0, 3)))
                    End If
                End If
                Set nrng = Nothing
            End If
        Next j
        Set rng = Nothing
    Next i
    For i = lr To 2 Step -1
        Set rng = ws.Range("E" & i)
            If rng.Value < 0 Then Rows(rng.Row & ":" & rng.Row).Delete
        Set rng = Nothing
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

編集:
あなたの基準によりよく一致するようにコードを少し変更しました。試してみて、フィードバックを残してください:)

Option Explicit

Sub Combine__And__Delete()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws As Worksheet
    Set ws = Sheets(1)

    Dim i&, j&, lr&, rng As Range, str$, com$, tmp, x#
    lr = ws.Range("A" & Rows.Count).End(xlUp).Row
    ReDim arr(lr - 2) As String
    For i = 2 To lr
        Set rng = ws.Range("A" & i)
        arr(i - 2) = rng.Text & "###" & rng.Offset(0, 2).Text
        Set rng = Nothing
    Next i

    Call RemoveDuplicate(arr)

    For i = LBound(arr) To UBound(arr)
        For j = lr To 2 Step -1
            Set rng = ws.Range("A" & j)
            str = rng.Text & "###" & rng.Offset(0, 2).Text
            If StrComp(str, arr(i), 1) = 0 Then
                x = x + CDbl(rng.Offset(0, 3).Value)
                com = rng.Offset(0, 1)
            End If
            Set rng = Nothing
        Next j
        arr(i) = arr(i) & "###" & CStr(x) & "###" & com
        x = 0
    Next i

    Rows("2:" & lr).Delete

    For i = LBound(arr) To UBound(arr)
        Set rng = ws.Range("A" & i + 2)
        tmp = Split(arr(i), "###")
        rng = tmp(0)
        rng.Offset(0, 1) = tmp(3)
        rng.Offset(0, 2) = tmp(1)
        rng.Offset(0, 3) = tmp(2)
        Set rng = Nothing
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub


Sub RemoveDuplicate(ByRef StringArray() As String)
    Dim lb&, ub&, TempArray() As String, cur&, A&, B&
    If (Not StringArray) = True Then Exit Sub
    lb = LBound(StringArray): ub = UBound(StringArray)
    ReDim TempArray(lb To ub): cur = lb: TempArray(cur) = StringArray(lb)
    For A = lb + 1 To ub
        For B = lb To cur
            If LenB(TempArray(B)) = LenB(StringArray(A)) Then
                If InStrB(1, StringArray(A), TempArray(B), vbBinaryCompare) = 1 Then Exit For
            End If
        Next B
        If B > cur Then cur = B: TempArray(cur) = StringArray(A)
    Next A
    ReDim Preserve TempArray(lb To cur): StringArray = TempArray
End Sub
于 2013-05-29T15:45:29.890 に答える