Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


3162 / 13644 ツリー ←次へ | 前へ→

【63799】品番と納期の検索 tek 09/12/16(水) 1:23 質問[未読]
【63800】Re:品番と納期の検索 SS 09/12/16(水) 10:37 発言[未読]
【63826】Re:品番と納期の検索 tek 09/12/18(金) 3:13 お礼[未読]
【63801】Re:品番と納期の検索 Hirofumi 09/12/16(水) 12:45 回答[未読]
【63827】Re:品番と納期の検索 tek 09/12/18(金) 3:17 お礼[未読]

【63799】品番と納期の検索
質問  tek  - 09/12/16(水) 1:23 -

引用なし
パスワード
   A   B   C  D
品番 納期 数量 ロット
:   :  :   :
データはその都度増加する


上記のような表があります
品番と納期が同じ物が会ったら数量を合計したい
のですが、いい方法がありますでしょうか?(VBAでつくりたいのですが?)


品番     納期    数量   ロット

13452 2009/12/15  100   4568567
13452 2009/12/15  500   3268457

13452 2009/12/15  600   合計値
これを出したら上のデータ行を削除して下のデータを残したいです
Loopさせて連続処理データ最終行でストップ

品番は数種類あり納期もばらばらですが、たまに同じ品番と納期がダブルときがあり
ます。
投げやりになりましたが教えていただける方よろしくお願いいたします。

【63800】Re:品番と納期の検索
発言  SS  - 09/12/16(水) 10:37 -

引用なし
パスワード
   ▼tek さん:
こんにちは、個人的に基データを消去するのにためらいを覚えることと
行参照管理がめんどくさそうなので別シートに整理する形で作ってみました。
1行目が見出しで2行目以降空白無しでデータが入っているものとします。
Dictionaryを使うほうが良いのかも知れませんが、私の使いなれたもので組んでみました。
Option Explicit
Sub Macro1()
  Dim i As Long, j As Long, k As Long, m As Long, n As Long
  Dim 品番 As Variant, 納期 As Variant, 数量 As Variant
  Dim flag As Integer
  Dim WR As Variant
  Dim UR As String
  
  m = 2
  ReDim WR(0)
  With Worksheets("Sheet1")
    k = .Range("a65536").End(xlUp).Row
    For i = 2 To k
      '以前ダブった行の処理を飛ばします。
      flag = 0
      For n = 0 To UBound(WR)
        If i = WR(n) Then flag = 1
      Next n
      If flag = 0 Then
        UR = ""
        品番 = .Cells(i, 1).Value
        納期 = .Cells(i, 2).Value
        数量 = .Cells(i, 3).Value
        For j = i + 1 To k
          If .Cells(j, 1).Value = 品番 Then
            If .Cells(j, 2).Value = 納期 Then
              数量 = 数量 + .Cells(j, 3).Value
              WR(UBound(WR)) = j
              ReDim Preserve WR(UBound(WR) + 1)
              UR = UR & "," & j
            End If
          End If
        Next j
        
        With Worksheets("Sheet2")
          .Cells(m, 1).Value = 品番
          .Cells(m, 2).Value = 納期
          .Cells(m, 3).Value = 数量
          '合計した行を記述します
          .Cells(m, 5).Value = i & UR
        End With
        m = m + 1
      End If
    Next i
  End With
End Sub

>A   B   C  D
>品番 納期 数量 ロット
>:   :  :   :
>データはその都度増加する
>
>
>上記のような表があります
>品番と納期が同じ物が会ったら数量を合計したい
>のですが、いい方法がありますでしょうか?(VBAでつくりたいのですが?)
>
>例
>品番     納期    数量   ロット
>
>13452 2009/12/15  100   4568567
>13452 2009/12/15  500   3268457
>↓
>13452 2009/12/15  600   合計値
>これを出したら上のデータ行を削除して下のデータを残したいです
>Loopさせて連続処理データ最終行でストップ
>
>品番は数種類あり納期もばらばらですが、たまに同じ品番と納期がダブルときがあり
>ます。
>投げやりになりましたが教えていただける方よろしくお願いいたします。

【63801】Re:品番と納期の検索
回答  Hirofumi  - 09/12/16(水) 12:45 -

引用なし
パスワード
   ロットはどうするのだろう?

Option Explicit

Public Sub Sample()

  'Listのデータ列数(A列〜D列)
  Const clngColumns As Long = 4

  'Listの中のKey1と成る列位置(基準列からの列Offset:0列目)
  Const clngKey1 As Long = 0
  'Listの中のKey2と成る列位置(基準列からの列Offset:1列目)
  Const clngKey2 As Long = 1
  'Listの中の集計列位置(基準列からの列Offset:2列目)
  Const clngItem As Long = 2
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntResult As Variant
  Dim vntData As Variant
  Dim lngTop As Long
  Dim lngCount As Long
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする(先頭列の列見出しのセル位置)
  Set rngList = ActiveSheet.Cells(1, "A")

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngKey1).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用Keyを設定
    .Offset(, clngColumns).EntireColumn.Insert
    With .Offset(1, clngColumns)
      .Value = 1
      .Resize(lngRows).DataSeries _
          Rowcol:=xlColumns, Type:=xlLinear, _
          Date:=xlDay, Step:=1, Trend:=False
    End With
    'データを「品番」順の「納期」順で整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1, clngKey1), Order1:=xlAscending, _
        Key2:=.Offset(1, clngKey2), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
  End With
  
  '画面更新を停止
'  Application.ScreenUpdating = False
  
  '先頭行を結果用配列に取得
  lngTop = 1
  vntResult = rngList.Offset(lngTop).Resize(, clngColumns + 1).Value
  'Key列に就いて繰り返し
  For i = 2 To lngRows + 1
    '1行分配列に取得
    vntData = rngList.Offset(i).Resize(, clngColumns + 1).Value
    '結果用配列と取得配列で「品番」「納期」が同値なら
    If vntResult(1, clngKey1 + 1) = vntData(1, clngKey1 + 1) _
        And vntResult(1, clngKey2 + 1) = vntData(1, clngKey2 + 1) Then
      '結果用配列に加算
      vntResult(1, clngItem + 1) = vntResult(1, clngItem + 1) _
                      + vntData(1, clngItem + 1)
      'ロット番号
      vntResult(1, clngColumns) = CStr(vntResult(1, clngColumns)) _
                      & "; " & CStr(vntData(1, clngColumns))
      '復帰用KeyをEmptyに
      rngList.Offset(i, clngColumns).Value = Empty
      '削除数を更新
      lngCount = lngCount + 1
    Else
      '結果用配列を出力
      rngList.Offset(lngTop).Resize(, clngColumns + 1).Value = vntResult
      '同値先頭行位置を更新
      lngTop = i
      '取得配列を結果用配列に代入
      vntResult = vntData
    End If
  Next i
  
  With rngList
    '復帰用Keyで整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '削除行が在る場合
    If lngCount > 0 Then
      '行削除
      .Offset(lngRows - lngCount + 1).Resize(lngCount).EntireRow.Delete
    End If
    '復帰用Keyを削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
    
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

【63826】Re:品番と納期の検索
お礼  tek  - 09/12/18(金) 3:13 -

引用なし
パスワード
   ▼SS さん:
早速返事ありがとうございました少し自分の希望に近い形に変更させてもらい
動かしたところうまくいきました。ありがとうございました。
tek


>▼tek さん:
>こんにちは、個人的に基データを消去するのにためらいを覚えることと
>行参照管理がめんどくさそうなので別シートに整理する形で作ってみました。
>1行目が見出しで2行目以降空白無しでデータが入っているものとします。
>Dictionaryを使うほうが良いのかも知れませんが、私の使いなれたもので組んでみました。
>Option Explicit
>Sub Macro1()
>  Dim i As Long, j As Long, k As Long, m As Long, n As Long
>  Dim 品番 As Variant, 納期 As Variant, 数量 As Variant
>  Dim flag As Integer
>  Dim WR As Variant
>  Dim UR As String
>  
>  m = 2
>  ReDim WR(0)
>  With Worksheets("Sheet1")
>    k = .Range("a65536").End(xlUp).Row
>    For i = 2 To k
>      '以前ダブった行の処理を飛ばします。
>      flag = 0
>      For n = 0 To UBound(WR)
>        If i = WR(n) Then flag = 1
>      Next n
>      If flag = 0 Then
>        UR = ""
>        品番 = .Cells(i, 1).Value
>        納期 = .Cells(i, 2).Value
>        数量 = .Cells(i, 3).Value
>        For j = i + 1 To k
>          If .Cells(j, 1).Value = 品番 Then
>            If .Cells(j, 2).Value = 納期 Then
>              数量 = 数量 + .Cells(j, 3).Value
>              WR(UBound(WR)) = j
>              ReDim Preserve WR(UBound(WR) + 1)
>              UR = UR & "," & j
>            End If
>          End If
>        Next j
>        
>        With Worksheets("Sheet2")
>          .Cells(m, 1).Value = 品番
>          .Cells(m, 2).Value = 納期
>          .Cells(m, 3).Value = 数量
>          '合計した行を記述します
>          .Cells(m, 5).Value = i & UR
>        End With
>        m = m + 1
>      End If
>    Next i
>  End With
>End Sub
>
>>A   B   C  D
>>品番 納期 数量 ロット
>>:   :  :   :
>>データはその都度増加する
>>
>>
>>上記のような表があります
>>品番と納期が同じ物が会ったら数量を合計したい
>>のですが、いい方法がありますでしょうか?(VBAでつくりたいのですが?)
>>
>>例
>>品番     納期    数量   ロット
>>
>>13452 2009/12/15  100   4568567
>>13452 2009/12/15  500   3268457
>>↓
>>13452 2009/12/15  600   合計値
>>これを出したら上のデータ行を削除して下のデータを残したいです
>>Loopさせて連続処理データ最終行でストップ
>>
>>品番は数種類あり納期もばらばらですが、たまに同じ品番と納期がダブルときがあり
>>ます。
>>投げやりになりましたが教えていただける方よろしくお願いいたします。

【63827】Re:品番と納期の検索
お礼  tek  - 09/12/18(金) 3:17 -

引用なし
パスワード
   ▼Hirofumi さん:

返信ありがとうございました。今回SSさんのほうを参考にさせてもらいました
次回このような機会がありましたら。またよろしくご教授ください。

tek


>ロットはどうするのだろう?
>
>Option Explicit
>
>Public Sub Sample()
>
>  'Listのデータ列数(A列〜D列)
>  Const clngColumns As Long = 4
>
>  'Listの中のKey1と成る列位置(基準列からの列Offset:0列目)
>  Const clngKey1 As Long = 0
>  'Listの中のKey2と成る列位置(基準列からの列Offset:1列目)
>  Const clngKey2 As Long = 1
>  'Listの中の集計列位置(基準列からの列Offset:2列目)
>  Const clngItem As Long = 2
>  
>  Dim i As Long
>  Dim lngRows As Long
>  Dim rngList As Range
>  Dim vntResult As Variant
>  Dim vntData As Variant
>  Dim lngTop As Long
>  Dim lngCount As Long
>  Dim strProm As String
>
>  '◆Listの先頭セル位置を基準とする(先頭列の列見出しのセル位置)
>  Set rngList = ActiveSheet.Cells(1, "A")
>
>  With rngList
>    '行数の取得
>    lngRows = .Offset(Rows.Count - .Row, clngKey1).End(xlUp).Row - .Row
>    If lngRows <= 0 Then
>      strProm = "データが有りません"
>      GoTo Wayout
>    End If
>    '復帰用Keyを設定
>    .Offset(, clngColumns).EntireColumn.Insert
>    With .Offset(1, clngColumns)
>      .Value = 1
>      .Resize(lngRows).DataSeries _
>          Rowcol:=xlColumns, Type:=xlLinear, _
>          Date:=xlDay, Step:=1, Trend:=False
>    End With
>    'データを「品番」順の「納期」順で整列
>    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
>        Key1:=.Offset(1, clngKey1), Order1:=xlAscending, _
>        Key2:=.Offset(1, clngKey2), Order2:=xlAscending, _
>        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
>        Orientation:=xlTopToBottom, SortMethod:=xlStroke
>  End With
>  
>  '画面更新を停止
>'  Application.ScreenUpdating = False
>  
>  '先頭行を結果用配列に取得
>  lngTop = 1
>  vntResult = rngList.Offset(lngTop).Resize(, clngColumns + 1).Value
>  'Key列に就いて繰り返し
>  For i = 2 To lngRows + 1
>    '1行分配列に取得
>    vntData = rngList.Offset(i).Resize(, clngColumns + 1).Value
>    '結果用配列と取得配列で「品番」「納期」が同値なら
>    If vntResult(1, clngKey1 + 1) = vntData(1, clngKey1 + 1) _
>        And vntResult(1, clngKey2 + 1) = vntData(1, clngKey2 + 1) Then
>      '結果用配列に加算
>      vntResult(1, clngItem + 1) = vntResult(1, clngItem + 1) _
>                      + vntData(1, clngItem + 1)
>      'ロット番号
>      vntResult(1, clngColumns) = CStr(vntResult(1, clngColumns)) _
>                      & "; " & CStr(vntData(1, clngColumns))
>      '復帰用KeyをEmptyに
>      rngList.Offset(i, clngColumns).Value = Empty
>      '削除数を更新
>      lngCount = lngCount + 1
>    Else
>      '結果用配列を出力
>      rngList.Offset(lngTop).Resize(, clngColumns + 1).Value = vntResult
>      '同値先頭行位置を更新
>      lngTop = i
>      '取得配列を結果用配列に代入
>      vntResult = vntData
>    End If
>  Next i
>  
>  With rngList
>    '復帰用Keyで整列
>    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
>        Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
>        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
>        Orientation:=xlTopToBottom, SortMethod:=xlStroke
>    '削除行が在る場合
>    If lngCount > 0 Then
>      '行削除
>      .Offset(lngRows - lngCount + 1).Resize(lngCount).EntireRow.Delete
>    End If
>    '復帰用Keyを削除
>    .Offset(, clngColumns).EntireColumn.Delete
>  End With
>    
>  strProm = "処理が完了しました"
>   
>Wayout:
>
>  '画面更新を再開
>  Application.ScreenUpdating = True
>  
>  Set rngList = Nothing
>   
>  MsgBox strProm, vbInformation
>     
>End Sub

3162 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free