Excel VBA質問箱 IV

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

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


33202 / 76738 ←次へ | 前へ→

【48760】Re:オートフィルターについて
回答  Hirofumi  - 07/5/5(土) 3:53 -

引用なし
パスワード
   オートフィルタを使わずに、単純な手法で行っています
1、Listを「店舗」昇順、「日付」昇順で整列します
 ただ、今回のコードでは、Listを元に戻す為、最終列の後ろに再整列用のKeyを
 先に出力しています
2、Listの「店舗」を上から見ていきます、探索KeyのKeyB1と同じ値が有った場合
 KeyA1の値になるまで集計を行います
3、次にListの「日付」を見て行き、KeyA1と同じ値が初めて有った時
 この行位置を記録し、同じ値の行をカウントしていきます
4、Listの「店舗」が違ったら、集計とカウントを辞めます
5、lngTopで記録した行位置から、カウントした行数を、List2にCopyし、
 集計結果を出力して終わります


Option Explicit

Public Sub Sample()

  '◆Listのデータ列数(A列〜AG列)
  Const clngColumns As Long = 33
  '◆「1係」の列位置を指定(基準セル位置からの列Offset:基準がA1で「1係」がD列なら3)
  Const clngBegin As Long = 3
  '◆「日付」の列位置を指定(基準セル位置からの列Offset:基準がA1で「日付」がA列なら0)
  Const clngDate As Long = 0
  '◆「店舗」の列位置を指定(基準セル位置からの列Offset:基準がA1で「店舗」がB列なら1)
  Const clngKey As Long = 1
  '◆「項目」の列位置を指定(基準セル位置からの列Offset:基準がA1で「項目」がC列なら2)
  Const clngItem As Long = 2
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntDate As Variant
  Dim vntKeys As Variant
  Dim vntItems As Variant
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntData As Variant
  Dim vntKeyA1 As Variant
  Dim vntKeyB1 As Variant
  Dim lngTop As Long
  Dim lngCount As Long
  Dim lngIndex As Long
  Dim strProm As String

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

  '◆List2の先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngResult = Worksheets("List2").Cells(5, "A")
  
  With rngResult
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngItem).End(xlUp).Row - .Row
    If lngRows > 0 Then
      '先回の結果をクリア (結果表示先List2のA:AF)
      .Offset(1).Resize(lngRows, clngColumns - 1).ClearContents
    End If
    '「日付」の抽出条件を取得
    vntKeyA1 = .Parent.Cells(2, 2).Value
    '「店舗」の抽出条件を取得
    vntKeyB1 = .Parent.Cells(3, 2).Value
  End With

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    ReDim vntData(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      vntData(i, 1) = i
    Next i
    '復帰用Keyの出力
    .Offset(1, clngColumns) _
          .Resize(lngRows).Value = vntData
    'データを「店舗」昇順の「日付」昇順で整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1, clngKey), Order1:=xlAscending, _
        Key2:=.Offset(1, clngDate), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '「日付」列データを配列に取得
    vntDate = .Offset(1, clngDate).Resize(lngRows + 1).Value
    '「店舗」列データを配列に取得
    vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
    '「項目」列データを配列に取得
    vntItems = .Offset(1, clngItem).Resize(lngRows + 1).Value
  End With
  
  '結果出力用配列を確保(売上と差益の累計値の集計用)
  ReDim vntResult(1, clngColumns - clngBegin)
  vntResult(0, 0) = "売上累計"
  vntResult(1, 0) = "差益累計"
  'Listのデータ行全てに就いて繰り返し
  For i = 1 To lngRows
    '「店舗」の値がKeyB1の値と合致した場合
    If StrComp(vntKeys(i, 1), vntKeyB1, vbTextCompare) = 0 Then
      '「日付」がKeyA1の値以下の場合
      If vntDate(i, 1) <= vntKeyA1 Then
        '項目が「売上」か"差益"なら
        If vntItems(i, 1) = "売上" Or vntItems(i, 1) = "差益" Then
          '1行分データを配列に取得
          vntData = rngList.Offset(i, clngBegin) _
                .Resize(, clngColumns - clngBegin).Value
          '項目が「売上」なら
          If vntItems(i, 1) = "売上" Then
            lngIndex = 0
          Else
            lngIndex = 1
          End If
          '「係」 単位に集計
          For j = 1 To clngColumns - clngBegin
            vntResult(lngIndex, j) _
                = vntResult(lngIndex, j) + vntData(1, j)
          Next j
        End If
        '「日付」がKeyA1の値合致し、lngTopが0の場合
        If vntDate(i, 1) = vntKeyA1 And lngTop = 0 Then
          '抽出行の先頭行位置を記録
          lngTop = i
          '抽出行数を1に
          lngCount = 1
        Else
          '抽出行数を更新
          lngCount = lngCount + 1
        End If
      End If
    Else
      '探索するKeyB1を通り過ぎた場合
      If lngTop > 0 Then
        'Forを抜ける
        Exit For
      End If
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '結果を出力
  With rngResult
    '抽出結果が有るなら
    If lngTop > 0 Then
      '列見出しを貼り付け
      rngList.Offset(, 1).Resize(lngCount, _
          clngColumns - 1).Copy Destination:=.Item(1)
      '抽出結果を貼り付け
      rngList.Offset(lngTop, 1).Resize(lngCount, _
          clngColumns - 1).Copy Destination:=.Offset(1)
      '累計を出力
      .Offset(lngCount + 1, 1).Resize(2, clngColumns _
                  - clngBegin).Value = vntResult
      strProm = "処理が完了しました"
    Else
      strProm = "抽出結果が有りません"
    End If
  End With
  
  With rngList
    'Listの再整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'Key列の削除
    .Offset(1, clngColumns).EntireColumn.Delete
  End With
  
   
Wayout:

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

【48743】オートフィルターについて hiro 07/5/4(金) 15:12 質問
【48745】Re:オートフィルターについて かみちゃん 07/5/4(金) 17:10 発言
【48751】Re:オートフィルターについて かみちゃん 07/5/4(金) 18:38 発言
【48754】Re:オートフィルターについて hiro 07/5/4(金) 20:09 発言
【48755】Re:オートフィルターについて かみちゃん 07/5/4(金) 20:39 発言
【48760】Re:オートフィルターについて Hirofumi 07/5/5(土) 3:53 回答
【48761】Re:オートフィルターについて Hirofumi 07/5/5(土) 11:31 回答
【48762】Re:オートフィルターについて hiro 07/5/5(土) 22:16 発言
【48763】Re:オートフィルターについて Hirofumi 07/5/5(土) 23:37 回答
【48764】Re:オートフィルターについて Hirofumi 07/5/6(日) 1:23 回答
【48767】Re:オートフィルターについて Hirofumi 07/5/6(日) 18:37 回答
【48768】Re:オートフィルターについて hiro 07/5/6(日) 21:24 お礼

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