Excel VBA質問箱 IV

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

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


33199 / 76738 ←次へ | 前へ→

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

引用なし
パスワード
   >hirofumi様にもう一つお聞きしたいのですが出力のさいに
>できれば行列を入れ替えたいのですが可能でしょうか?

「Sub Sample2」(AdvancedFilter版)のコードは、
出力もAdvancedFilterに依存していますので無理です
ただし、「Sub Sample」の方は、行列を入れ替える方法を採れば可能です

Option Explicit

Public Sub Sample3()

  '◆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")
  '結果表の出力を右1列ずらす例
'  Set rngResult = Worksheets("List2").Cells(5, "B")
  
  With rngResult
    '先回の結果をクリア
    .CurrentRegion.ClearContents '★変更
    '「日付」の抽出条件を取得
    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(clngColumns - clngBegin, 1)    '★変更
  vntResult(0, 0) = "売上累計"           '★変更
  vntResult(0, 1) = "差益累計"           '★変更
  '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(j, lngIndex) _
                = vntResult(j, lngIndex) + 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
      '結果出力用配列を確保
      ReDim vntItems(1 To clngColumns - 1, lngCount) '★追加
      '列見出しを配列に取得
      vntData = rngList.Offset(, 1).Resize(lngCount, _
                  clngColumns - 1).Value '★変更
      '列見出しを行列変換して結果出力用配列に格納
      For i = 1 To clngColumns - 1          '★追加
        vntItems(i, 0) = vntData(1, i)       '★追加
      Next i                     '★追加
      '抽出結果を配列に取得
      vntData = rngList.Offset(lngTop, 1) _
          .Resize(lngCount, clngColumns - 1).Value '★変更
      'データを行列変換して結果出力用配列に格納
      For i = 1 To clngColumns - 1          '★追加
        For j = 1 To lngCount            '★追加
          vntItems(i, j) = vntData(j, i)     '★追加
        Next j                   '★追加
      Next i                     '★追加
      '結果を出力
      .Resize(clngColumns - 1, _
            lngCount + 1).Value = vntItems   '★追加
      .Offset(clngBegin - 2, lngCount + 1) _
          .Resize(clngColumns - clngBegin + 1, _
              2).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 お礼

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