Excel VBA質問箱 IV

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

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


32913 / 76734 ←次へ | 前へ→

【49049】Re:月別集計
回答  Hirofumi  - 07/5/21(月) 19:49 -

引用なし
パスワード
   AdvancedFilterを使って店別・月別・項目別・係別で「売上」だけを集計しています
尚、日付は、1年分しか無い物としてコードを作っています
また、日付が、シリアル値の場合と「20070401」形式の場合でコードが違います
日付が、シリアル値の場合は、●印の下の行を活かして下さい
日付が、「20070401」形式の場合は、★印の下の行を活かして下さい
(Upのコードはコメントアウトして有ります)
集計結果は、店舗名のシートが有ればそれが使われますし、無い場合は作成されます
ただし、作成されると言っても、見出しが出力される程度でので、
予め、店舗名のシートを作って、罫線、書式等が有るならそれを設定して下さい

Option Explicit

Public Sub Sample()

  'List1の各緒言
  '◆List1のデータ列数(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 clngStores As Long = 1
  '◆「項目」の列位置を指定(基準セル位置からの列Offset:基準がA1で「項目」がC列なら2)
  Const clngItem As Long = 2

  '出力シートの各緒言
  '◆出力基準位置を指定
  Const cstrResult As String = "A3"
  '◆先頭「01係」の行位置(上記の基準からの行Offset)
  Const clngNo As Long = 3

  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim lngTop As Long
  Dim lngRow As Long
  Dim lngColumn As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult() As Range
  Dim rngWork As Range
  Dim vntResult As Variant
  Dim vntStores As Variant
  Dim vntData As Variant
  Dim vntTitle As Variant
  Dim vntItems As Variant
  Dim lngMonth As Long
  Dim lngPitch As Long
  Dim lngCalc As Long
  Dim strProm As String

  '再計算の方法を保存
  lngCalc = Application.Calculation

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

  '◆出力表の行見出しを設定
  vntTitle = Array("年実績", "前年比", "達成率", "年実績", "年目標")
  lngPitch = UBound(vntTitle) + 1

  With rngList
    '行数の取得
    lngRows = .CurrentRegion.Rows.Count - 1
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    vntData = .Offset(1, clngStores).Resize(lngRows + 1).Value
    ReDim vntStores(0)
    vntStores(0) = vntData(1, 1)
    For i = 2 To lngRows
      For j = 0 To UBound(vntStores)
        If vntData(i, 1) = vntStores(j) Then
          Exit For
        End If
      Next j
      If j > UBound(vntStores) Then
        ReDim Preserve vntStores(UBound(vntStores) + 1)
        vntStores(UBound(vntStores)) = vntData(i, 1)
      End If
    Next i
    Erase vntData
    vntItems = .Offset(, clngBegin).Resize(, clngColumns - clngBegin)
  End With

  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
  End With

  '出力シートの存在確認
  ReDim rngResult(UBound(vntStores))
  For i = 0 To UBound(vntStores)
    If SheetExists(vntStores(i)) Then
      Set rngResult(i) = Worksheets(vntStores(i)).Range(cstrResult)
      With rngResult(i).Parent
        .Cells.ClearContents
        .Activate
      End With
    Else
      Set rngResult(i) = Worksheets.Add( _
                  After:=ActiveSheet).Range(cstrResult)
      rngResult(i).Parent.Name = vntStores(i)
    End If
  Next i

  '作業用シートを追加
  With Worksheets
    Set rngWork = .Add(After:=.Item(.Count)).Cells(1, "A")
  End With

  With rngWork
    rngList.Resize(, clngColumns).Copy Destination:=.Item(1)
    With .Offset(, clngColumns)
      .Offset(, 1).Value = rngList.Offset(, clngStores).Value
      .Offset(, 2).Value = rngList.Offset(, clngItem).Value
      .Offset(1, 2).Value = "売上"
    End With
    '「店舗」別にAdvancedFilterで、「売上」を抽出
    For i = 0 To UBound(vntStores)
      '店舗条件を出力
      .Offset(1, clngColumns + 1).Value = vntStores(i)
      DoFilter rngList.CurrentRegion, .Offset(, clngColumns _
              + 1).Resize(2, 2), .Resize(, clngColumns)
      lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
      If lngRows < 1 Then
        Exit For
      End If
      .Offset(1).Resize(lngRows, clngColumns).Sort _
        Key1:=.Offset(1), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
      vntData = .Offset(1).Resize(lngRows, clngColumns).Value
      ReDim vntResult(1 To (clngColumns - clngBegin) * lngPitch, 1 To 12)
      lngTop = 1
      '★月の値を取得(「20070401」形式の場合)
'      lngMonth = Val(Mid(vntData(lngTop, clngDate + 1), 5, 2))
      '●月の値を取得(シリアル値の場合)
      lngMonth = Month(vntData(lngTop, clngDate + 1))
      lngColumn = (lngMonth + 8) Mod 12 + 1
      For j = 1 To clngColumns - clngBegin
        lngRow = (j - 1) * lngPitch + 1
        vntResult(lngRow, lngColumn) = vntData(lngTop, clngBegin + j)
      Next j
      For j = 2 To lngRows
        '★月が違った場合(「20070401」形式の場合)
'        If Val(Mid(vntData(j, clngDate + 1), 5, 2)) <> lngMonth Then
        '●月が違った場合(シリアル値の場合)
        If Month(vntData(j, clngDate + 1)) <> lngMonth Then
          lngTop = j
          '★月の値を取得(「20070401」形式の場合)
'          lngMonth = Val(Mid(vntData(lngTop, clngDate + 1), 5, 2))
          '●月の値を取得(シリアル値の場合)
          lngMonth = Month(vntData(lngTop, clngDate + 1))
        End If
        lngColumn = (lngMonth + 8) Mod 12 + 1
        For k = 1 To clngColumns - clngBegin
          lngRow = (k - 1) * lngPitch + 1
          vntResult(lngRow, lngColumn) _
              = vntResult(lngRow, lngColumn) _
                  + vntData(lngTop, clngBegin + k)
        Next k
      Next j
      With rngResult(i)
        .Offset(clngNo, 2).Resize(UBound(vntResult, 1), _
                UBound(vntResult, 2)).Value = vntResult
        OutputTerminate .Item(1), vntItems, _
            Val(Left(vntData(1, clngDate + 1), 4)), vntTitle, clngNo
      End With
    Next i
    rngResult(0).Parent.Activate
  End With

  strProm = "処理が完了しました"

Wayout:

  If Not rngWork Is Nothing Then
    Application.DisplayAlerts = False
    rngWork.Parent.Delete
    Application.DisplayAlerts = True
  End If

  With Application
    .Calculation = lngCalc
    .Calculate
    .ScreenUpdating = True
  End With

  Set rngWork = Nothing
  Set rngList = Nothing
  For i = 0 To UBound(rngResult)
    Set rngResult(i) = Nothing
  Next i

  MsgBox strProm, vbInformation

End Sub

Private Sub DoFilter(rngScope As Range, rngCriteria As Range, _
          rngCopyTo As Range)

  rngScope.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=rngCriteria, _
      CopyToRange:=rngCopyTo, _
      Unique:=False

End Sub

Private Function SheetExists(vntName As Variant) As Boolean

  Dim i As Long

  For i = 1 To Worksheets.Count
    If StrComp(Worksheets(i).Name, vntName, vbTextCompare) = 0 Then
      Exit For
    End If
  Next i
  If i <= Worksheets.Count Then
    vntName = Worksheets(i).Name
    SheetExists = True
  End If
      
End Function

Private Sub OutputTerminate(rngTop As Range, _
              vntName As Variant, _
              lngYear As Long, _
              vntTitle As Variant, _
              lngStart As Long)

  Dim i As Long
  Dim j As Long
  Dim lngPitch As Long
  Dim vntResult As Variant
  Dim vntTmp As Variant

  '出力ピッチを取得
  lngPitch = UBound(vntTitle) + 1

  '行見出し作成用の配列を作成
  ReDim vntResult(1 To UBound(vntName, 2) * lngPitch + lngStart, 1 To 2)
  vntResult(1, 1) = "係"
  vntResult(2, 2) = Right(CStr(lngYear - 1), 2) & vntTitle(0)
  vntResult(3, 2) = Right(CStr(lngYear), 2) & vntTitle(UBound(vntTitle))
  For i = 1 To UBound(vntName, 2)
    vntResult(lngStart + (i - 1) * lngPitch + 1, 1) = vntName(1, i)
    For j = 0 To UBound(vntTitle)
      vntTmp = vntTitle(j)
      Select Case j
        Case 0, lngPitch - 1
          vntTmp = Right(CStr(lngYear), 2) & vntTmp
        Case lngPitch - 2
          vntTmp = Right(CStr(lngYear - 1), 2) & vntTmp
      End Select
      vntResult(lngStart + (i - 1) * lngPitch + j + 1, 2) = vntTmp
    Next j
  Next i
  With rngTop
    '行見出しの出力
    .Resize(UBound(vntResult, 1), 2).Value = vntResult
    '列見出しの作成
    ReDim vntResult(11)
    For i = 0 To 11
      vntResult(i) = ((i + 3) Mod 12 + 1) & "月"
    Next i
    .Offset(, 2).Resize(, UBound(vntResult) + 1).Value = vntResult
    '算式の代入
    For i = 1 To UBound(vntName, 2)
      .Offset(lngStart + (i - 1) * lngPitch + 1, 2).Resize(, 12).FormulaR1C1 _
          = "=IF(R[2]C="""","""",ROUND(R[-1]C/R[2]C,2))"
      .Offset(lngStart + (i - 1) * lngPitch + 2, 2).Resize(, 12).FormulaR1C1 _
          = "=IF(R[2]C="""","""",ROUND(R[-2]C/R[2]C,4))"
    Next i
  End With

End Sub
1 hits

【49008】月別集計 hiro 07/5/20(日) 23:52 質問
【49016】Re:月別集計 Hirofumi 07/5/21(月) 7:43 発言
【49018】Re:月別集計 Hirofumi 07/5/21(月) 8:42 発言
【49049】Re:月別集計 Hirofumi 07/5/21(月) 19:49 回答
【49052】Re:月別集計 hiro 07/5/21(月) 21:27 お礼
【49056】Re:月別集計 hiro 07/5/21(月) 23:31 発言
【49058】Re:月別集計 Hirofumi 07/5/22(火) 0:39 回答
【49062】Re:月別集計 Hirofumi 07/5/22(火) 10:20 回答
【49063】Re:月別集計 hiro 07/5/22(火) 10:35 発言
【49075】Re:月別集計 Hirofumi 07/5/22(火) 15:19 発言
【49078】Re:月別集計 Hirofumi 07/5/22(火) 16:04 回答
【49079】Re:月別集計 Hirofumi 07/5/22(火) 16:06 回答
【49088】Re:月別集計 Hirofumi 07/5/22(火) 18:51 発言
【49089】Re:月別集計 hiro 07/5/22(火) 19:13 発言
【49091】Re:月別集計 Hirofumi 07/5/22(火) 19:53 回答
【49092】Re:月別集計 Hirofumi 07/5/22(火) 20:28 回答
【49094】Re:月別集計 hiro 07/5/22(火) 20:46 発言
【49095】Re:月別集計 Hirofumi 07/5/22(火) 21:35 回答
【49102】Re:月別集計 Hirofumi 07/5/23(水) 9:36 回答
【49114】Re:月別集計 hiro 07/5/23(水) 21:23 お礼
【49116】Re:月別集計 Hirofumi 07/5/23(水) 21:45 発言

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