戻る  □一般操作のサロン  □ 使用方法  □ 新着記事  □ 新規に質問する!  □ トピック一覧  □ 検索  □ 過去ログ
[ 親トピックをトピックトップへ ]
このトピックに書きこむ
Name/
E-Mail/

└>このツリーのレス記事をメールで受信しますか? YES/ NO/
Title/
URL/
Comment/ 通常モード->  図表モード-> (←の場合適当に改行を入れて下さい)
タグが使用できます。例 ⇒ <font color="blue">文字</font>
解決!!ありがとうございました! 解決       保留中です・・・ 保留        迷宮入りorほかあたって見ます・・ 迷宮入       すいませ〜ん。誰か〜! Help! ←※回答者専用
解決したらチェック       保留(コードテスト中など・・)         解決不可orレスが全く付かなくてほかのサイトに行くときなど・・
削除キー/
(半角8文字以内) 

このトピック参照回数 :
Re[2]: 重複データの先頭行に合計値を入力して先頭行以外を削除したい

    [195683] Re[2]: 重複データの先頭行に合計値を入力して先頭行以外を削除したい-

    解決!!ありがとうございました! / 記事引用/メール受信=OFF■

    □投稿者/ IZU -(2023/04/05(12:55))
    □U R L/
      kazuo様 ご回答頂きありがとうございます。
      
      
      ご提示頂いた修正コードで希望する結果に至る事ができました。
      ありがとうございます。
      
      下記が頂いたコードを元に変更したコードになります。
      追加でI列が空白な場合は処理をスキップするコードを
      For分に追記したいのですが、何故かまたオブジェクトエラーが
      でて頓挫を繰り返しています。
      また煮詰まったら改めて質問を投稿しますので、その時はまたお力添え頂ければ
      幸いです。
      
      
      Sub RemoveDuplicateRowsAndSumD()
          Dim r As Range, rr As Range
          Dim dict As Object
          Dim c As String
          Dim d As Double
          Dim cof As Long
          
          Set dict = CreateObject("Scripting.Dictionary")
          With Sheets("INVOICE")
              cof = .Range("I1").Column - .Range("C1").Column
              Set rr = .Range("C65", .Cells(.Rows.Count, "C").End(xlUp))
          End With
          For Each r In rr
              c = r.Value & vbTab & r.Offset(, cof).Value
              d = IIf(IsNumeric(r.Offset(, 1).Value), r.Offset(, 1).Value, 0) '★数値判定し、処置
              If dict.Exists(c) Then          '重複データの場合
                  r.Offset(, 1).Value = ""        'Blank
              Else                            '重複していない場合
                  r.Offset(, 1).Value = 1         'Blank以外
              End If
              dict(c) = dict(c) + d           '合計値を加算
          Next
          '重複行削除
          On Error Resume Next
          rr.Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
          On Error GoTo 0
          '合計値を出力   '★dict.count(表範囲)以外は無視
          rr.Offset(, 1).Value = Application.Transpose(dict.items)
      End Sub
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他



      ++++++++++++++++++++
      OS      ⇒OTHER
      Version⇒OTHER
      ++++++++++++++++++++




    [195681] Re[1]: 重複データの先頭行に合計値を入力して先頭行以外を削除したい-

    記事引用/メール受信=OFF■

    □投稿者/ kazuo -(2023/04/04(20:33))
    □U R L/
      >D列に文字列があった場合
      判定を追加し、文字列なら例えば0とかに置き換えれば良いのではと思います。
      
      >指定した行以降からマクロを実行
      指定可能にコーディングすれば良いのではと思います。
      
      かなり変形してしまいましたが一例です。
      
      Sub RemoveDuplicateRowsAndSumD()
          Dim r As Range, rr As Range
          Dim dict As Object
          Dim c As String
          Dim d As Double
          Dim cof As Long
          Dim 指定した行 As Range
          
          On Error Resume Next
          Set 指定した行 = Application.InputBox("集計シートの開始行を指定下さい", Type:=8)
          On Error GoTo 0
          If 指定した行 Is Nothing Then Exit Sub
          Set dict = CreateObject("Scripting.Dictionary")
          With 指定した行.Worksheet
              cof = .Range("I1").Column - .Range("C1").Column
              Set rr = .Range("C" & 指定した行.Row, .Cells(.Rows.Count, "C").End(xlUp))
          End With
          For Each r In rr
              c = r.Value & vbTab & r.Offset(, cof).Value
              d = IIf(IsNumeric(r.Offset(, 1).Value), r.Offset(, 1).Value, 0) '★数値判定し、処置
              If dict.Exists(c) Then          '重複データの場合
                  r.Offset(, 1).Value = ""        'Blank
              Else                            '重複していない場合
                  r.Offset(, 1).Value = 1         'Blank以外
              End If
              dict(c) = dict(c) + d           '合計値を加算
          Next
          '重複行削除
          On Error Resume Next
          rr.Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
          On Error GoTo 0
          '合計値を出力   '★dict.count(表範囲)以外は無視
          rr.Offset(, 1).Value = Application.Transpose(dict.items)
          Application.Goto 指定した行
      End Sub
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [195680] 重複データの先頭行に合計値を入力して先頭行以外を削除したい-

    ■親トピック/記事引用/メール受信=OFF■

    □投稿者/ IZU -(2023/04/04(16:22))
    □U R L/
      行き詰っているので助けて頂きたいです。
      
      INVOICEというSheetのC列に商品コード、I列に製品名、D列に数量が入力された
      シートがあり、I列の製品名が同じ括りの中で、C列の商品コードに重複があった
      場合に重複先頭行へしその商品コードの数量を合計した数値を出力したうえで、
      先頭行以外の重複行を削除するマクロがあります。
      
      下記マクロで希望した結果は出力されるのですが、D列に文字列があった場合や指定した行以降からマクロを実行したい場合に実行時エラー13が出てどうしてもエラーが修正できません。
      
      ご指摘頂けると幸いです。
      
      Sub RemoveDuplicateRowsAndSumD()
      Dim lastRow As Long
      Dim ws As Worksheet
      
      Set ws = Sheets("INVOICE")
      lastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row 'C列の最終行を取得
      
      Dim dict As Object
      Set dict = CreateObject("Scripting.Dictionary")
      
      Dim i As Long
      For i = lastRow To 2 Step -1 '最終行から上に向かってループ
          Dim c As String, iVal As String
          Dim d As Double
          
          c = ws.Cells(i, "C").Value
          iVal = ws.Cells(i, "I").Value
          d = ws.Cells(i, "D").Value  ←ここ行でエラーがでます。
          
          If dict.Exists(c & iVal) Then '重複データの場合
              dict(c & iVal) = dict(c & iVal) + d '合計値を加算
              ws.Rows(i).Delete '重複行を削除
          Else '重複していない場合
              dict.Add c & iVal, d '合計値を初期化
          End If
      Next i
      
      '重複先頭行に合計値を出力
      For i = 2 To lastRow
          Dim key As String
          key = ws.Cells(i, "C").Value & ws.Cells(i, "I").Value
          
          If dict.Exists(key) Then
              ws.Cells(i, "D").Value = dict(key)  ←ここではオブジェクト定義エラーがよくでます。
              dict.Remove key
          End If
      Next i
      
      End Sub


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他



      ++++++++++++++++++++
      OS      ⇒OTHER
      Version⇒OTHER
      ++++++++++++++++++++



このトピック内容の全ページ数 / [0]

- Child Forum -
Edit:ゆう-G