Excel VBA質問箱 IV

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

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


18373 / 76732 ←次へ | 前へ→

【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

1 hits

【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 お礼

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