Excel VBA質問箱 IV

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

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


18347 / 76732 ←次へ | 前へ→

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

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