Excel VBA質問箱 IV

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

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


45041 / 76732 ←次へ | 前へ→

【36698】Re:特定の文字列をシート名に含むシートのみ串刺し計算
回答  Hirofumi  - 06/4/8(土) 15:16 -

引用なし
パスワード
   こんなかな?

Option Explicit

Public Sub Sample()

  'データの入出力範囲
  Const cstrScope As String = "D18:D30"
  
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim vntData As Variant
  Dim vntSum() As Variant
  Dim strKeys() As String
  Dim lngKeys As Long
  Dim strKey As String
  Dim lngPos As Long
  Dim wksCurrent As Worksheet
  Dim strProm As String
  
  'Key探索用配列のサイズ初期値
  lngKeys = -1
  '全てのWorkSheetに就いて繰り返し
  For Each wksCurrent In Worksheets
    With wksCurrent
      'シート名の"-"の位置を取得
      lngPos = InStr(1, .Name, "-", vbTextCompare)
      '"-"が有ったら
      If lngPos > 0 Then
        'D18:D30のデータを取得
        vntData = .Range(cstrScope).Value
        '集計位置探索のKeyを作成
        strKey = Left(.Name, lngPos - 1)
        '集計用配列の集計位置を探索
        For j = 0 To lngKeys
          If StrComp(strKeys(j), strKey, vbTextCompare) = 0 Then
            Exit For
          End If
        Next j
        '探索値が有った場合
        If j <= lngKeys Then
          '位置を保存
          lngPos = j
          '集計位置に加算
          For j = 1 To UBound(vntData, 2)
            For k = 1 To UBound(vntData, 1)
              vntSum(lngPos)(k, j) _
                  = vntSum(lngPos)(k, j) + vntData(k, j)
            Next k
          Next j
        Else
          '集計用配列のサイズを更新
          lngKeys = lngKeys + 1
          '集計用配列、Key配列を拡張
          ReDim Preserve vntSum(lngKeys), strKeys(lngKeys)
          '集計用配列に値を代入
          vntSum(lngKeys) = vntData
          'Key配列にKeyを追加
          strKeys(lngKeys) = strKey
        End If
      End If
    End With
  Next wksCurrent
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Key全てに就いて繰り返し
  For i = 0 To UBound(strKeys, 1)
    'Keyに"合計"を付加
    strKeys(i) = strKeys(i) & "合計"
    Set wksCurrent = Nothing
    '集計シートを探索
    For Each wksCurrent In Worksheets
      'Keyに対するシートが有った場合
      If StrComp(wksCurrent.Name, strKeys(i), vbTextCompare) = 0 Then
        'Forを抜ける
        Exit For
      End If
    Next wksCurrent
    'もし、シートが無い場合
    If wksCurrent Is Nothing Then
      'シートを追加して、シート名を変更
      With Worksheets
        Set wksCurrent = .Add(After:=.Item(.Count))
      End With
      wksCurrent.Name = strKeys(i)
    End If
    '集計データを出力
    wksCurrent.Range(cstrScope).Value = vntSum(i)
  Next i
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set wksCurrent = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub
0 hits

【36692】特定の文字列をシート名に含むシートのみ串刺し計算 VBA☆ 06/4/8(土) 8:51 質問
【36693】Re:特定の文字列をシート名に含むシートの... VBA☆ 06/4/8(土) 8:57 質問
【36694】Re:特定の文字列をシート名に含むシートの... ponpon 06/4/8(土) 12:12 発言
【36695】Re:特定の文字列をシート名に含むシートの... Kein 06/4/8(土) 12:38 回答
【36698】Re:特定の文字列をシート名に含むシートの... Hirofumi 06/4/8(土) 15:16 回答
【36701】Re:特定の文字列をシート名に含むシートの... ichinose 06/4/8(土) 20:08 発言
【36702】Re:特定の文字列をシート名に含むシートの... ichinose 06/4/9(日) 8:10 発言
【36703】みなさまありがとうございます VBA☆ 06/4/9(日) 14:49 お礼
【36773】遅くなりました。 [名前なし] 06/4/13(木) 14:56 質問
【36779】Re:遅くなりました。 Kein 06/4/13(木) 16:16 回答
【36789】Re:遅くなりました。 ponpon 06/4/13(木) 21:19 発言

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