Excel VBA質問箱 IV

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

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


18035 / 76732 ←次へ | 前へ→

【64141】Re:受注データの表示形式について
回答  Hirofumi  - 10/1/21(木) 20:10 -

引用なし
パスワード
   >膨大な受注データ
て、どれくらい?
処理に時間が掛かるかも?
「受注データ」がShee1に在り、「受注年月日」の列見出しがA1に在る物とします
結果の「加工後データ」をSheet2に出力します

手順は
「受注年月日」、「商品CD」、「商品名」、「単価」でListwp整列
'List上から見て行って、「受注年月日」、「商品CD」、「商品名」、「単価」が
一致すれば、「受注先」を追加
一致しなければ、Sheet2に出力

Option Explicit

Public Sub Sample()

  '「受注データ」の列数設定(A〜E列)
  Const clngColumns As Long = 5
  '集列(「受注先」列)の列位置(基準セル位置からの列Offset:E列)
  Const clngItems As Long = 4
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntTop As Variant
  Dim vntData As Variant
  Dim vntKeys As Variant
  Dim vntOrders As Variant
  Dim lngMax As Long
  Dim lngWrite As Long
  Dim strProm As String
  
  'Listの先頭セル位置を基準とする(先頭列の列見出しのセル位置)
  Set rngList = Worksheets("Sheet1").Range("A1")
  
  '結果出力の先頭セル位置を基準セル位置とする(先頭列の列見出しのセル位置)
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  With rngResult
    'シートをクリア
    .Parent.Cells.ClearContents
    '列見出しを出力
    .Resize(, clngColumns).Value = rngList.Resize(, clngColumns).Value
    .Offset(, clngColumns - 1).Value _
        = .Offset(, clngColumns - 1).Value & "グループ"
  End With
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '復帰用整列Keyを作成
  With rngList.Offset(1, clngColumns)
    .Value = 1
    .Resize(lngRows).DataSeries _
        Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Trend:=False
  End With
  
  '整列Keyを作成(「受注年月日」を第0列として
  '「受注年月日」、「商品CD」、「商品名」、「単価」を列挙)
  vntKeys = Array(0, 1, 2, 3)
  '整列順を設定
  lngMax = UBound(vntKeys)
  ReDim vntOrders(lngMax)
  For i = 0 To lngMax
    vntOrders(i) = xlAscending
  Next i
  'データ「受注年月日」、「商品CD」、「商品名」、「単価」順に取得
  DataSort rngList.Offset(1).Resize(lngRows, clngColumns + 1), vntKeys, vntOrders
  
  'Listの先頭〜最終で繰り返し
  vntTop = rngList.Offset(1).Resize(, clngColumns).Value
  For i = 2 To lngRows + 1
    'Listから1レコード分取得
    vntData = rngList.Offset(i).Resize(, clngColumns).Value
    '配列の先頭から最終まで比較
    For j = 0 To lngMax
      If vntTop(1, vntKeys(j) + 1) <> vntData(1, vntKeys(j) + 1) Then
        Exit For
      End If
    Next j
    '前列一致した場合
    If j > lngMax Then
      '「受注先」を追加
      vntTop(1, clngItems + 1) = vntTop(1, clngItems + 1) _
                  & "、" & vntData(1, clngItems + 1)
    Else
      '集計レコードを出力
      lngWrite = lngWrite + 1
      rngResult.Offset(lngWrite).Resize(, clngColumns).Value = vntTop
      '配列の中身を入れ替え
      vntTop = vntData
    End If
  Next i
    
  With rngList
    '復帰用KeyをKeyとして整列
    DataSort .Offset(1).Resize(lngRows, clngColumns + 1), _
                 Array(clngColumns), Array(xlAscending)
    '削除Flag列を削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
  
   strProm = "処理が完了しました"
  
Wayout:

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

Private Sub DataSort(rngScope As Range, _
          vntKeys As Variant, _
          vntOrders As Variant)
  
  Dim i As Long
  Dim j As Long
  Dim vntTKeys As Variant
  Dim vntTOrders As Variant
  Dim lngNum As Long
  Dim vntKey(1 To 3) As Variant
  Dim vntOrder(1 To 3) As Variant
  
  vntTKeys = vntKeys
  vntTOrders = vntOrders
  
  lngNum = -Int(-(UBound(vntTKeys) + 1) / 3) * 3 - 1
  ReDim Preserve vntTKeys(lngNum), vntTOrders(lngNum)
  
  With rngScope
    For i = lngNum To 0 Step -3
      Erase vntKey
      For j = 3 To 1 Step -1
        If Not IsEmpty(vntTKeys(i + j - 3)) Then
          Set vntKey(j) = .Cells(1, 1).Offset(, vntTKeys(i + j - 3))
          vntOrder(j) = vntTOrders(i + j - 3)
        Else
          vntOrder(j) = xlAscending
        End If
      Next j
      .Sort _
        Key1:=vntKey(1), Order1:=vntOrder(1), _
        Key2:=vntKey(2), Order2:=vntOrder(2), _
        Key3:=vntKey(3), Order3:=vntOrder(3), _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    Next i
  End With
  
  For i = 1 To 3
    Set vntKey(i) = Nothing
  Next i
  
End Sub
1 hits

【64135】受注データの表示形式について Akari 10/1/21(木) 14:39 質問
【64141】Re:受注データの表示形式について Hirofumi 10/1/21(木) 20:10 回答
【64375】Re:受注データの表示形式について Akari 10/1/31(日) 22:27 質問
【64384】Re:受注データの表示形式について UO3 10/2/1(月) 12:57 回答
【64482】Re:受注データの表示形式について Akari 10/2/14(日) 21:57 質問
【64539】Re:受注データの表示形式について Akari 10/2/21(日) 21:37 質問
【64540】Re:受注データの表示形式について UO3 10/2/21(日) 22:06 発言
【64543】Re:受注データの表示形式について UO3 10/2/22(月) 11:38 回答
【64640】Re:受注データの表示形式について Akari 10/2/27(土) 21:23 質問
【64644】Re:受注データの表示形式について UO3 10/2/28(日) 1:37 発言
【64645】Re:受注データの表示形式について UO3 10/2/28(日) 9:03 回答
【64680】Re:受注データの表示形式について Akari 10/3/7(日) 14:00 質問
【64544】Re:受注データの表示形式について Hirofumi 10/2/22(月) 12:30 発言
【64846】Re:受注データの表示形式について akari 10/3/18(木) 15:35 お礼
【68776】Re:受注データの表示形式について Akari 11/4/16(土) 13:57 質問

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