エクセルVBA私はこのようになり、データ持って重複行を組み合わせると数量に

Question

を追加します。

Col A | Col B | Col C 
name 1| Item 1| 3 
name 2| Item 3| 1 
name 3| Item 2| 2 
name 2| Item 3| 6 
name 3| Item 2| 4 
name 2| Item 3| 3 

をそして、私は重複行のために大量の最後の列を追加し、重複行を削除するには、コードの行を必要とします。したがって、上記の表には、次のようになります。

Col A | Col B | Col C 
name 1| Item 1| 3 
name 2| Item 3| 10 
name 3| Item 2| 6 

を私は他の人の質問から複数の方法を試してみましたが、私は、「エラー：400」を取得しておきます。

For Each a In tm.Range("B2", Cells(Rows.Count, "B").End(xlUp)) 
    For r = 1 To Cells(Rows.Count, "B").End(xlUp).Row - a.Row 
     If a = a.Offset(r, 0) And a.Offset(0, 1) = a.Offset(r, 1) And a.Offset(0, 2) = a.Offset(r, 2) Then 
      a.Offset(0, 4) = a.Offset(0, 4) + a.Offset(r, 4) 
      a.Offset(r, 0).EntireRow.Delete 
      r = r - 1 
     End If 
    Next r 
Next a 


With Worksheets("Card Test") 

With .Range("b2:e2").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row) 
    .Copy 
    With .Offset(, .Columns.Count + 1) 
     .PasteSpecial xlPasteAll ' copy value and formats 
     .Columns(2).Offset(1).Resize(.Rows.Count - 1, 2).FormulaR1C1 = "=SUMIF(C1,RC1,C[-" & .Columns.Count + 1 & "])" 
     .Value = .Value 
     .RemoveDuplicates 1, xlYes 
    End With 
End With 

End With 

はまた、私は、私は2つのワークシートとデータとは別のシートになりますマクロを使用して、ボタンを持っていることを言及する必要があります：

はここで二つの例です。それも問題を引き起こしているようです。

Answer 1

あなたの問題を解決するためにループ FOR を使用することができます。

Sub RemoveDuplicates() 

Dim lastrow As Long 

lastrow = Cells(Rows.Count, "A").End(xlUp).Row 

For x = lastrow To 1 Step -1 
    For y = 1 To lastrow 
     If Cells(x, 1).Value = Cells(y, 1).Value And Cells(x, 2).Value = Cells(y, 2).Value And x > y Then 
      Cells(y, 3).Value = Cells(x, 3).Value + Cells(y, 3).Value 
      Rows(x).EntireRow.Delete 
      Exit For 
     End If 
    Next y 
Next x 


End Sub 

Answer 2

デフォルトの「のModule1」で、ワークブック内のコードモジュールを作成します。列挙宣言を一番上にして、次の3つの項目をそのモジュールに貼り付けます。列挙型を変更することができます。NumItem = 3は、次の行に続くので、アイテムの名前が「C」でNumQtyが自動的に4（「D」）の列を作成します。列がある今、B、Cの

プライベート列挙型のNumメインプロシージャの上部に

NumName = 1      ' Column Names 
NumItem 
NumQty 
NumFirstRow = 2     ' First data row 

エンド列挙

Sub CreateMergedList()

Dim Ws As Worksheet 
Dim Comp As String, Comp1 As String 
Dim R As Long, Rend As Long, Rsum As Long 
Dim Qty As Single 

Set Ws = Worksheets("Source") 
Ws.Copy Before:=Sheets(1) 

With Ws 
    ' There is one caption row which is excluded from sorting 
    With .UsedRange 
     .Sort .Columns(NumName), Key2:=.Columns(NumItem), Header:=xlYes 
     Rend = .Rows.Count 
    End With 

    For R = NumFirstRow To Rend - 1 
     If Comp = vbNullString Then Comp = CompareString(Ws, R) 
     Comp1 = CompareString(Ws, R + 1) 
     If StrComp(Comp, Comp1) Then 
      Comp = vbNullString 
      Rsum = R + 1 
     Else 
      If Rsum = 0 Then Rsum = NumFirstRow 
      Qty = .Cells(Rsum, NumQty).Value 
      .Cells(Rsum, NumQty).Value = Qty + .Cells(R + 1, NumQty).Value 
      .Cells(R + 1, NumName).Value = "" 
     End If 
    Next R 

    For R = Rend To (NumFirstRow - 1) Step -1 
     If .Cells(R, NumName).Value = "" Then .Rows(R).Delete 
    Next R 
End With 

Application.DisplayAlerts = False 
Worksheets(1).Delete 
Application.DisplayAlerts = True 
End Sub 

Private Function CompareString(Ws As Worksheet, R As Long) As String

With Ws.Rows(R) 
    CompareString = .Cells(NumName).Value & "|" & .Cells(NumItem).Value 
End With 
End Function 

は、「ワークシートの名前を変更します「名前」、「アイテム」、および「数量」を持つ独自のワークシートの名前が何であれ「ソース」を選択します。

コードはまずワークシートのコピーを作成します。その後、名前と項目でソートします。その後、数量を組み合わせて余分な行を削除します。

コードの最後にコピーが削除されます。削除を許可するかどうかを確認するには、 "Application.DisplayAlerts = False"行の先頭にアポストロフィを追加して、そのコマンドを無効にします。

この目的のために持っているボタンのClickイベントから、「CreateMergedList」プロシージャを呼び出します。楽しむ！

Answer 3

あなたはDictionaryオブジェクト

Option Explicit 

Sub main() 
    Dim cell As Range, dataRng As Range 
    Dim key As Variant 

    With Worksheets("Card Test") 
     Set dataRng = .Range("A1", .Cells(.Rows.count, "A").End(xlUp)) 
    End With 

    With CreateObject("Scripting.Dictionary") 
     For Each cell In dataRng 
      key = cell.Value & "|" & cell.Offset(, 1).Value 
      .item(key) = .item(key) + cell.Offset(, 2).Value 
     Next 
     dataRng.Resize(, 3).ClearContents 
     dataRng.Resize(.count) = Application.Transpose(.Keys) 
     dataRng.Resize(.count).Offset(, 2) = Application.Transpose(.Items) 
     dataRng.Resize(.count).TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:="|" 
    End With 
End Sub