Excel VBA質問箱 IV

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

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


7802 / 13645 ツリー ←次へ | 前へ→

【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 発言[未読]

【36692】特定の文字列をシート名に含むシートのみ...
質問  VBA☆  - 06/4/8(土) 8:51 -

引用なし
パスワード
   みなさんおはようございます。

今頭を抱えているのが題名にある件なのですが、まったく同じリスト形式のシートがたくさんあって、シート名に特定の文字列を含むもののみの集計シート(各シートと同じ形式)を作りたいのです。

集計対象のセルが少なければfor each〜などで合計=合計+rg.valueでいけると思うのですが、対象のセルがD18:G30と結構多いのでセルの数だけ変数を作って加算していく・・・というのはスマートではない気がします。

まだ初心者で配列みたいなものを理解していないのですが、D18:D30という決まった範囲を配列に取り込んで?シート名を検索キーにしてhitしたものだけ串刺しという方法は可能でしょうか?

質問もうまくかけないドがつく素人ですが、ヒントだけでもいただけたらと思い書き込みをさせていただきました。

みなさまよろしくお願いします。

【36693】Re:特定の文字列をシート名に含むシート...
質問  VBA☆  - 06/4/8(土) 8:57 -

引用なし
パスワード
   提供してる情報が少なすぎますね・・・・

まずシート名ですが、200-001(相手先コード-取引番号)という規則をもっています。ex)200-001、200-002、200-003、201-001、300-001、300-001・・・

集計の検索キーは相手先コードで、相手先ごとの集計シートを作成したいです。
200合計、201合計・・・

串刺し集計したいセル範囲はどのシートもD18:D30で、集計シートも同じ表で集計値をいれる場所も同じD18:D30です。

他にも必要な情報等ありましたらご指摘ください。
よろしくお願いします。

【36694】Re:特定の文字列をシート名に含むシート...
発言  ponpon  - 06/4/8(土) 12:12 -

引用なし
パスワード
   こんにちは。
Dictionaryの練習に作ってみました。
うまくいくかどうか自信はありませんが、試してみてください。
エラー処理などは、出来ていません。


Sub test()
  Dim mySHnm As String
  Dim NewSH As Worksheet
  Dim SH As Worksheet
  Dim myDic As Object
  Dim myVal As Variant
  Dim myVal2 As Variant
  
  '「・・の合計」のシートの削除
  Application.ScreenUpdating = False
  For Each SH In ThisWorkbook.Worksheets
    Application.DisplayAlerts = False
    If Right$(SH.Name, 2) = "合計" Then
     SH.Delete
    End If
    Application.DisplayAlerts = True
  Next
  
  'シートネームの左から3文字を辞書のkeyに、D18からD30をitemに格納
  Set myDic = CreateObject("Scripting.Dictionary")
  For i = 1 To ThisWorkbook.Worksheets.Count
   mySHnm = Left$(Sheets(i).Name, 3)
   myVal = Sheets(i).Range("D18", Sheets(i).Range("D30")).Value
   If Not myDic.exists(mySHnm) Then
     myDic(mySHnm) = myVal
   Else  '同じkeyなら配列の足し算
     myVal2 = myDic(mySHnm)
     For j = 1 To UBound(myVal2)
      myVal2(j, 1) = myVal2(j, 1) + myVal(i, 1)
     Next
     myDic(mySHnm) = myVal2
   End If
  Next
  
  'key毎にシートを追加、itemの転記
  For Each mykey In myDic.Keys
    Set NewSH = Worksheets.Add(after:=Sheets(Sheets.Count))
    With NewSH
      .Name = mykey & "合計"
      .Range("D18", .Range("D30")).Value = myDic(mykey)
    End With
  Next
  Application.ScreenUpdating = True
  Set myDic = Nothing: Set NewSH = Nothing
End Sub

【36695】Re:特定の文字列をシート名に含むシート...
回答  Kein  - 06/4/8(土) 12:38 -

引用なし
パスワード
   こんな感じで、どうでしょーか ?

Sub Code集計()
  Dim i As integer, j As Integer, Scnt As Integer
  Dim Sary() As String, Snm As String

  Application.ScreenUpdating = False
  Scnt = Worksheets.Count
  ReDim Sary(0): Sary(0) = ""
  For i = 1 To Scnt
   With Worksheets(i)
     If InStr(1, .Name, "-") = 0 Then GoTo NLine
     If Right$(.Name, 1) = "計" Then Exit For
     Snm = Split(.Name, "-")(0) & "計"
     If IsError(Application.Match(Snm, Sary, 0)) Then
      j = j + 1: ReDim Preserve Sary(j): Sary(j) = Snm 
      .Copy After:=Worksheets(SCnt)
      Worksheets(SCnt + 1).Name = Snm
     Else
      .Range("D18:D30").Copy
      Worksheets(Snm).Range("D18").PasteSpecial _
       xlPasteValues, xlPasteSpecialOperationAdd
      Application.CutCopyMode = False
     End If
   End With
NLine:
  Next i
  On Error Resume Next
  Worksheets(1).Activate
  Application.ScreenUpdating = True
  Erase Sary
End Sub

【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

【36701】Re:特定の文字列をシート名に含むシート...
発言  ichinose  - 06/4/8(土) 20:08 -

引用なし
パスワード
   皆さん、こんばんは。


>まずシート名ですが、200-001(相手先コード-取引番号)という規則をもっています。ex)200-001、200-002、200-003、201-001、300-001、300-001・・・
仮に集計するシートを「集計」というシート名だとすると

'==============================================================
Sub main()
  Const 検索 = "200" '相手先コード---200で集計
  Const セル範囲 = "$D$18:$D$30"
  Const shukei = "集計" '集計するシート名
  Worksheets(shukei).Range(セル範囲).Value = 0
  For Each sht In Worksheets
    If sht.Name Like 検索 & "-*" Then
     Worksheets(shukei).Range(セル範囲).Value = _
            Evaluate("'" & shukei & "'!" & セル範囲 & "+'" & _
            sht.Name & "'!" & セル範囲)
     End If
    Next
End Sub


配列をつかいました
確認してみて下さい

【36702】Re:特定の文字列をシート名に含むシート...
発言  ichinose  - 06/4/9(日) 8:10 -

引用なし
パスワード
   おはようございます。
シートを相手先コード別に作成して集計するのですね!!
よく読んでませんでした。
配列を使う方法で前回の投稿を変更しました。

'===========================
Sub main()
  Dim sht As Worksheet
  Dim tarray As Variant
  Dim wsht As Worksheet
  Dim idx As Long
  Dim wcnt As Long
  Const セル範囲 = "d18:d30"
  On Error Resume Next
  wcnt = Worksheets.Count
  For idx = 1 To wcnt
    Set sht = Worksheets(idx)
    tarray = Split(sht.Name, "-")
    If UBound(tarray) > 0 And tarray(0) <> "" Then
     Err.Clear
     Set wsht = Worksheets(tarray(0) & "合計")
     If Err.Number <> 0 Then
       Set wsht = Worksheets.Add(after:=Worksheets(Worksheets.Count))
       wsht.Name = tarray(0) & "合計"
       wsht.Range(セル範囲).Value = 0
       End If
     wsht.Range(セル範囲).Value = Evaluate("'" & wsht.Name & "'!" & セル範囲 & "+'" & _
                             sht.Name & "'!" & セル範囲)
     End If
    Next
  Set sht = Nothing
  Set wsht = Nothing
  On Error GoTo 0
End Sub

【36703】みなさまありがとうございます
お礼  VBA☆  - 06/4/9(日) 14:49 -

引用なし
パスワード
   みなさまサンプルコードの記載をたくさんありがとうございます。
お礼が遅くなり申し訳ありませんでした><
月曜日に会社でテストをしたいと思います。
結果はまた報告いたしますのでよろしくお願いします。

【36773】遅くなりました。
質問  [名前なし]  - 06/4/13(木) 14:56 -

引用なし
パスワード
   みなさまこんにちわ。

時間がなくdictionaryを使ったもののみテストをしてみたのですがうまく動きませんでした・・・

dictionaryオブジェクトについてはヘルプにも情報が乏しいのでここで質問させていただきたいのですが、keyとitemがあって、itemに配列を取得することはできないのでしょうか?

dim myval as variant

myval=range("D18:H30").value

dic.Add "key",myval

よろしくお願いいたします。

【36779】Re:遅くなりました。
回答  Kein  - 06/4/13(木) 16:16 -

引用なし
パスワード
   Dictionaryオブジェクトのヘルプを抜粋して提示しておきます。
-------------------------------------------------------------------
Dictionary オブジェクト参 照
FileSystemObject オブジェクト | TextStream オブジェクト
言語
JScript

VBScript

すべて表示
キーと項目を対で格納するオブジェクトです。

解説
Dictionary オブジェクトは、PERL 関連の配列と同じです。
項目はデータの任意の形式で配列に保存されます。各項目には、項目を一意に識別
するためのキーが関連付けられます。キーは、それぞれの項目を取り出すときに
使用されます。キーは、配列以外の値を使用します。通常では整数値または文字列を
使用します。

次のコードは、Dictionary オブジェクトを作成する例です。

[VBScript]
Dim d  ' Create a variable.
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "アテネ"  ' キーと項目を追加します。
d.Add "b", "ベオグラード"
d.Add "c", "カイロ"
...
メソッド
Add メソッド (Dictionary オブジェクト) | Exists メソッド |
Items メソッド | Keys メソッド | Remove メソッド | RemoveAll メソッド

プロパティ
Count プロパティ | Item プロパティ | Key プロパティ
----------------------------------------------------------------------
>keyとitemがあって、itemに配列を取得することはできないのでしょうか?
どちらも配列になります。Itemを配列にしたものは Items です。
そのヘルプも抜粋しておきます。
---------------------------------------------------------------------
Items メソッド参 照
Add メソッド (Dictionary オブジェクト) | Exists メソッド |
Keys メソッド | Remove メソッド | RemoveAll メソッド

対象: Dictionary オブジェクト
言語
JScript

VBScript

すべて表示
Dictionary オブジェクト内のすべての項目を格納した配列を返します。

object.Items( )
object には、Dictionary オブジェクトの名前を指定します。

解説
次のコードは、Items メソッドの使用例です。

[VBScript]
Function DicDemo
  Dim a, d, i, s  ' 変数を作成します。
  Set d = CreateObject("Scripting.Dictionary")
  d.Add "a", "アテネ"  ' キーと項目を追加します。
  d.Add "b", "ベオグラード"
  d.Add "c", "カイロ"
  a = d.Items  ' 項目を取得します。
  For i = 0 To d.Count -1 ' 取得した配列に繰り返し処理を行います。
   s = s & a(i) & "<BR>" ' 結果を返します。
  Next
  DicDemo = s
End Function

【36789】Re:遅くなりました。
発言  ponpon  - 06/4/13(木) 21:19 -

引用なし
パスワード
   こんばんは。
よりによって私のを試すなんて、
他の超ベテランの3人の方のを試されれば良かったものを・・・・
どこでどんなエラーが出ますか?
サンプルシートを作成し、他の方のものもすべて実行してみましたが、
私のコードと同じ結果になっています。
ただ、私のはシート名から左3文字を取得していますので、そこのところが違うだけです。そこは、変更がききますが・・・

>keyとitemがあって、itemに配列を取得することはできないのでしょうか?
私のコードは、itemに配列を入れていますが・・・

>  'シートネームの左から3文字を辞書のkeyに、D18からD30をitemに格納
>  Set myDic = CreateObject("Scripting.Dictionary")
>  For i = 1 To ThisWorkbook.Worksheets.Count
>   mySHnm = Left$(Sheets(i).Name, 3)
>   myVal = Sheets(i).Range("D18", Sheets(i).Range("D30")).Value
>   If Not myDic.exists(mySHnm) Then
>     myDic(mySHnm) = myVal
>   Else  '同じkeyなら配列の足し算
>     myVal2 = myDic(mySHnm)
>     For j = 1 To UBound(myVal2)
>      myVal2(j, 1) = myVal2(j, 1) + myVal(i, 1)
>     Next
>     myDic(mySHnm) = myVal2
>   End If
>  Next

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