Excel VBA質問箱 IV

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

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


11823 / 13644 ツリー ←次へ | 前へ→

【13588】検索したデータを特定のシートへ貼り付ける ハルコ 04/5/8(土) 15:29 質問[未読]
【13597】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/9(日) 11:39 回答[未読]
【13608】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/9(日) 16:20 質問[未読]
【13613】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/9(日) 18:23 回答[未読]
【13617】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/9(日) 20:02 質問[未読]
【13618】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/9(日) 20:44 回答[未読]
【13620】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/9(日) 21:21 質問[未読]
【13664】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/10(月) 20:06 回答[未読]
【13666】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/10(月) 21:24 質問[未読]
【13668】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/10(月) 21:48 回答[未読]
【13669】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/10(月) 23:12 質問[未読]
【13719】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/11(火) 20:18 回答[未読]
【13721】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/11(火) 21:10 回答[未読]
【13722】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/11(火) 22:24 質問[未読]
【13755】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/12(水) 19:50 回答[未読]
【13760】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/12(水) 22:17 質問[未読]
【13801】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/13(木) 21:49 回答[未読]
【13845】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/15(土) 1:31 質問[未読]
【13849】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/15(土) 7:31 回答[未読]
【13889】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/15(土) 19:20 質問[未読]
【13895】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/15(土) 20:56 回答[未読]
【13900】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/15(土) 23:29 質問[未読]
【13901】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/16(日) 0:23 質問[未読]
【13903】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/16(日) 1:45 回答[未読]
【13909】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/16(日) 19:07 質問[未読]
【13910】Re:検索したデータを特定のシートへ貼り付... Hirofumi 04/5/16(日) 21:07 回答[未読]
【13911】Re:検索したデータを特定のシートへ貼り付... ハルコ 04/5/16(日) 22:48 お礼[未読]

【13588】検索したデータを特定のシートへ貼り付け...
質問  ハルコ  - 04/5/8(土) 15:29 -

引用なし
パスワード
   みなさん、こんにちは。以前にも私の質問に対して、快くご回答していただいた方ありがとうございました。また今回も分からないことがあり、投稿させていただきました。標題のとおり、検索したデータを特定のシートへ貼り付ける、という作業なのですが、考えているとおり、うまくいきません。具体的には、次のとおりの作業で、その次に考えたコードをのせています。もちろん、このコードでは何ら反応しません。まだ、初心者で四苦八苦しながらやっているのですが、どうしてもわからいので、どうかお力を貸してください。宜しくお願いします。

1.シート1にデータがあります。データの内容は次のとおりです。
 これらのデータは毎日、シート1へ貼り付けられます。
 従いまして、B列の日付けデータ・A列の店名・B〜G列の数字は
 毎日、違います。又、グループ数(各日にちのデータをいいます)も違います。 ちなみに、1・2行は文字列が入っていますので省略させていただきます。
  A  B    C   D  E   F    G 
1   
2
3    20040401
4    貸分      借分    貸借合計
5    件数   金額  件数 金額  件数  金額
6 A店 2    1,000 5  6,500 7    7,500
7 B店 3    2,000 3  2,000 6    4,000
8 合計 5    3,000 8  8,500 13    11,500
9    20040402
10   貸分      借分    貸借合計
11 A店 1    1,000 5  6,500 6    7,500
12 D店 3    2,000 3  2,000 6    4,000
13 G店 2    1,000 5  6,500 7    7,500
14 合計 6    4,000 13  15,000 19    19,000
15           ・
16           ・

2.D列の借分の件数・金額を、B列の日付データを検索条件として、1日〜31日分のシートにある表のセルE1と合致するシートを検索し、貼り付けます。店数は全部で33店あります。
 その表は以下のとおりです。
(4月1日分の場合)
 B   E    Q   R
1   20040401
2
3
4        件数 金額
5 A店
6 B店 
7 C店
8 D店
9 E店
10 F店
 ・
 ・
37 AG店

3.モジュールです。この内容では、セルB3の日付分のデータだけしか検索することができません。これをシート1のB列の全ての日付分のデータを検索し、対象となる日付シートへ貼り付けたいのです。なお、前述でもふれましたが、店数が多いことから、以下のようなコードですと、かなりのコードを入力しなくてはなりません。
このことから、もっと省略できるようなコードがありましたら、併せて、ご教授をお願いいたします。

Sub 日計表へ移行()

  Dim i As Integer
  Dim 行番号 As Long
  Dim 列番号 As Long
  Dim 選択シート() As Variant
  Dim 検索文字 As String
  Dim 合致セル As Range
  Dim 日付 As Range

  Application.ScreenUpdating = false

  Worksheets("シート1").Select
  
'グループ1.について日計表へ移行させる。

  ReDim 選択シート(31)
  検索文字 = Range("B3").Value

’シートを検索する。  
  For i = 5 To 35
    Set 合致セル = Worksheets(i).Cells(1, 5).Find(検索文字,    
       LookIn:=xlValues, lookat:=xlPart)
    If Not 合致セル Is Nothing Then
      If 選択シート(1) = "" Then
        選択シート(1) = i
      End If
    End If
  Next i
’当月分のデータではない時、メッセージをだす。      
  If 選択シート(1) = "" Then
    MsgBox "グループ1.については、他の月の分です。"
  
  Else
    行番号 = 3
    列番号 = 1
    
    For 行番号 = 3 To 65536 Step 1
      If Cells(行番号, 列番号) = "" And Cells(行番号, 列番号 + 1)  
= "" Then
        Exit For
      End If
    
      If Cells(行番号, 列番号) = "A店" Then
        Cells(行番号, 列番号 + 3).Copy
        Worksheets(選択シート(1)).Select
        Range("Q5").PasteSpecial   OPERATION:=xlPasteSpecialOperationAdd, _
          Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        Worksheets("シート1").Select
        Cells(行番号, 列番号 + 4).Copy
        Worksheets(選択シート(1)).Select
        Range("R5").PasteSpecial OPERATION:=xlPasteSpecialOperationAdd, _
          Paste:=xlPasteValues
        Application.CutCopyMode = False
      
      ElseIf Cells(行番号, 列番号) = "B支店" Then
        Worksheets("シート1").Select
        Cells(行番号, 列番号 + 3).Copy
        Worksheets(選択シート(1)).Select
        Range("Q6").PasteSpecial OPERATION:=xlPasteSpecialOperationAdd, _
          Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        Worksheets("シート1").Select
        Cells(行番号, 列番号 + 4).Copy
        Worksheets(選択シート(1)).Select
        Range("R6").PasteSpecial OPERATION:=xlPasteSpecialOperationAdd, _
          Paste:=xlPasteValues
        Application.CutCopyMode = False    
      End If
    Next  
  End If    
  Application.ScreenUpdating = True  
End Sub

【13597】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/9(日) 11:39 -

引用なし
パスワード
   以下の条件と、Dictionaryオブジェクトが使える環境(大抵は使えると思います)なら
こんなコードかな?
上手く行かなかったゴメン

B1セルに日付と認められる値が有るシートを転記先のシートとする
転記先のシートは、同一レイアウトで、店舗名も全て同位置に有る物とする

以下を標準モジュールに記述して下さい

Option Explicit

'シートの最終行位置を定数として宣言
Const clngSheetEnd As Long = 65536

Public Sub Classification()

  'Sheet1のデータ先頭行を定数として宣言
  Const clngDataTop As Long = 3

  Dim i As Long
  Dim lngDataEnd As Long
  Dim dicSheets As Object
  Dim dicStore As Object
  Dim vntData As Variant
  Dim lngSheetNo As Long
  Dim lngStoreNo As Long
  Dim blnCopy As Boolean
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'シートのIndexをDictionaryとして取得
  Set dicSheets _
      = CreateObject("Scripting.Dictionary")
  '店のIndexをDictionaryとして取得
  Set dicStore _
      = CreateObject("Scripting.Dictionary")
  
  'シートのIndexを作成
  If Not MakeSheetsIndex(dicSheets, lngSheetNo) Then
    GoTo ExitHandler
  End If
  
  '店のIndexを作成
  If Not MakeStoreIndex(dicStore, lngSheetNo) Then
    GoTo ExitHandler
  End If
  
  'データの有るシートに就いて
  With Worksheets("Sheet1")
    'データの最終行を取得
    lngDataEnd = .Cells(clngSheetEnd, "A").End(xlUp).Row
    'データの有る先頭行〜最終行まで繰り返し
    For i = clngDataTop To lngDataEnd
      '配列にi行のA、B列を取得
      vntData = .Cells(i, 1).Resize(, 2).Value
      'もし、i行B列のセル値が日付と認識されるなら
      If DateCheck(vntData(1, 2)) Then
        'もし、シートのIndexにこの日付が有るなら
        If dicSheets.Exists(vntData(1, 2)) Then
          'シートの番号を取得
          lngSheetNo _
            = CLng(dicSheets.Item(vntData(1, 2)))
          'コピーフラグをTrueに
          blnCopy = True
        '日付が無いなら
        Else
          '当月分と認めず、このグループを無視
          MsgBox vntData(1, 2) & "、他の月の分です。"
          'コピーフラグをFalseに
          blnCopy = False
        End If
      'i行B列のセル値が日付と認識されないなら
      Else
        'コピーフラグがTrueなら
        If blnCopy Then
          '店舗Indexにi行A列の値が有るなら
          If dicStore.Exists(vntData(1, 1)) Then
            '店舗の行位置を取得
            lngStoreNo _
              = CLng(dicStore.Item(vntData(1, 1)))
            'Sheet1のi行D、E列をコピーして、店舗の行位置に張りつけ
            .Cells(i, "D").Resize(, 2).Copy _
              Worksheets(lngSheetNo).Cells(lngStoreNo, "Q")
          End If
        End If
      End If
    Next i
  End With
  
  Beep
  MsgBox "処理が完了しました"
  
ExitHandler:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  'Dictionaryを破棄
  Set dicSheets = Nothing
  Set dicStore = Nothing

End Sub

Private Function DateCheck(ByVal _
          vntValue As Variant) As Boolean

'  日付のチェック

  If vntValue = "" Then
    Exit Function
  End If
  If Len(vntValue) <> 8 Then
    Exit Function
  End If
  vntValue = Left(vntValue, 4) _
        & "/" & Mid(vntValue, 5, 2) _
          & "/" & Right(vntValue, 2)
  If IsDate(vntValue) Then
    DateCheck = True
  End If
  
End Function

Private Function MakeSheetsIndex(dicSheets As Object, _
              lngSheetNo As Long) As Boolean

'  B1セルに日付の有るシートのIndexを作成


  Dim i As Long
  Dim vntDate As Variant
  
  'ワークシートコレクションに就いて
  With Worksheets
    'コレクションの先頭から終りまで繰り返し
    For i = 1 To .Count
      'シートiのB1の値を取得
      vntDate = .Item(i).Cells(1, "B").Value
      'もし、日付と認められるなら
      If DateCheck(vntDate) Then
        'シートのIndexにこの日付が有る場合
        If dicSheets.Exists(vntDate) Then
          Beep
          MsgBox "同一の日付が有ります"
          Exit Function
        '日付が無い場合
        Else
          'Indexにこの日付とシート番号を追加
          dicSheets.Add vntDate, i
          '最初にIndexに追加されたシート番号を保存
          If lngSheetNo = 0 Then
            lngSheetNo = i
          End If
        End If
      End If
    Next i
  End With
  
  MakeSheetsIndex = True
  
End Function

Private Function MakeStoreIndex(dicStore As Object, _
              lngSheetNo As Long) As Boolean

'  店舗のIndexを作成

  '店舗データの先頭行位置を定数宣言
  Const clngDataTop As Long = 5
  
  Dim i As Long
  Dim vntData As Variant
  
  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)
    '店舗名を配列に取得
    vntData = Range(.Cells(clngDataTop, "A"), _
          .Cells(clngSheetEnd, "A").End(xlUp)).Value
  End With
  '店舗Indexに就いて
  With dicStore
    '店舗名の先頭から終まで繰り返し
    For i = 1 To UBound(vntData, 1)
      'Indexにi番目の店舗名が有るなら
      If .Exists(vntData(i, 1)) Then
        Beep
        MsgBox "同一の店名が有ります"
        Exit Function
      'i番目の店舗名が無いなら
      Else
        'Indexに店舗名と行位置を追加
        .Add vntData(i, 1), i + clngDataTop - 1
      End If
    Next i
  End With

  MakeStoreIndex = True
  
End Function

【13608】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/9(日) 16:20 -

引用なし
パスワード
   ▼Hirofumi さん、またお世話になります。
 ご回答の内容について、拝見させていただきました。私にはかなり難しい内容で すが、「シートのIndexをDictionaryとして取得」というところは、こういうこ とも出きるんだなと、大変勉強になりました。(^^)
 さて、ご指示のとおり、標準モジュールに入力し、実行してみましたが、以下の 部分について、エラーが出てしまいました。

>  '最初にIndexに追加されたシート番号に就いて
>  With Worksheets(lngSheetNo)

 前回の質問では、データがあるシート名を「シート1」として現しましたが、実は、実際のファイルでは違うシート名なのです。ですので、"シート1"という部分は、実際のシート名に変えたのですが、これがまずかったのでしょうか?又、私の説明が足りなかったのですが、転記先のシートに日付と認められるセルは「E1」なので、これも訂正したのですが、これもまずかったのでしょうか?

併せて、次の意味を簡単に教えていただけないでしょうか?
'コピーフラグをTrueに
   blnCopy = True


以上のとおりです。色々と面倒ですが、ご教授のほど、宜しくお願いします。

【13613】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/9(日) 18:23 -

引用なし
パスワード
   ゴメン、私も善く見ないで回答してしまった

>>  '最初にIndexに追加されたシート番号に就いて
>>  With Worksheets(lngSheetNo)

ここで、エラーが出るのは、指定セル位置が日付と認められる転記先のシートが無い事に因ると思われます
詰まり、lngSheetNoが0の値だと思います

>転記先のシートに日付と認められるセルは「E1」なので、これも訂正したのですが、

これは何処を訂正されたのですか?
この修正場所は、以下の部分ですので以下の様に修正して下さい

「B1セルに日付の有るシートのIndexを作成」と書いて有るプロシージャの中で、

      'シートiのB1の値を取得
      vntDate = .Item(i).Cells(1, "B").Value


      'シートiのB1の値を取得
      vntDate = .Item(i).Cells(1, "E").Value

として下さい

また、

> 前回の質問では、データがあるシート名を「シート1」として現しましたが、
>実は、実際のファイルでは違うシート名なのです。
>ですので、"シート1"という部分は、実際のシート名に変えたのですが、
>これがまずかったのでしょうか?

これは、以下の部分を修正されたのなら問題有りません

  'データの有るシートに就いて
  With Worksheets("Sheet1")

のSheet1の部分

>併せて、次の意味を簡単に教えていただけないでしょうか?
>'コピーフラグをTrueに
>   blnCopy = True

の意味は、もし、Sheet1のB列の日付が転記先に無い場合、
其の日付以降で次の日付までのデータを転記させない為の処理です
詰まり、blnCopy = Trueの時は、転記が行われ、
blnCopy = Falseに成ると、転記が行われ無く成ります

PS:
 コードを色々いじる事は、賛成です(いじらなければ解らない)
 ただ、動かない場合、コードをいじっているなら、其の部分を具体的に書いて下さい

【13617】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/9(日) 20:02 -

引用なし
パスワード
   すみませんでした。今度から修正した部分を書くようにします。

Hirofumiさんがおっしゃるとおり、以下のように修正して、実行しましたが、エラーが出てしまいます。

これも報告漏れですが、ブック内のシートの配置について、補足させていただきます。1〜5番目のシートの内、データがあるシートが3番目になります。6〜36番目のシートが、日にちごとのシートになります。(シート名は「1」「30」という感じです。)

このシートの配置にも問題があるのでしょうか?
宜しくお願いいたします。


Option Explicit

'シートの最終行位置を定数として宣言
Const clngSheetEnd As Long = 65536

Public Sub Classification()

  'Sheet1のデータ先頭行を定数として宣言
  Const clngDataTop As Long = 3

  Dim i As Long
  Dim lngDataEnd As Long
  Dim dicSheets As Object
  Dim dicStore As Object
  Dim vntData As Variant
  Dim lngSheetNo As Long
  Dim lngStoreNo As Long
  Dim blnCopy As Boolean
 
  '画面更新を停止
  Application.ScreenUpdating = False
 
  'シートのIndexをDictionaryとして取得
  Set dicSheets _
      = CreateObject("Scripting.Dictionary")
  '店のIndexをDictionaryとして取得
  Set dicStore _
      = CreateObject("Scripting.Dictionary")
 
  'シートのIndexを作成
  If Not MakeSheetsIndex(dicSheets, lngSheetNo) Then
    GoTo ExitHandler
  End If
 
  '店のIndexを作成
  If Not MakeStoreIndex(dicStore, lngSheetNo) Then
    GoTo ExitHandler
  End If
 
  'データの有るシートに就いて
  With Worksheets("集計表")   ←ここです
    'データの最終行を取得
    lngDataEnd = .Cells(clngSheetEnd, "A").End(xlUp).Row
    'データの有る先頭行〜最終行まで繰り返し
    For i = clngDataTop To lngDataEnd
      '配列にi行のA、B列を取得
      vntData = .Cells(i, 1).Resize(, 2).Value
      'もし、i行B列のセル値が日付と認識されるなら
      If DateCheck(vntData(1, 2)) Then
        'もし、シートのIndexにこの日付が有るなら
        If dicSheets.Exists(vntData(1, 2)) Then
          'シートの番号を取得
          lngSheetNo _
            = CLng(dicSheets.Item(vntData(1, 2)))
          'コピーフラグをTrueに
          blnCopy = True
        '日付が無いなら
        Else
          '当月分と認めず、このグループを無視
          MsgBox vntData(1, 2) & "、他の月の分です。"
          'コピーフラグをFalseに
          blnCopy = False
        End If
      'i行B列のセル値が日付と認識されないなら
      Else
        'コピーフラグがTrueなら
        If blnCopy Then
          '店舗Indexにi行A列の値が有るなら
          If dicStore.Exists(vntData(1, 1)) Then
            '店舗の行位置を取得
            lngStoreNo _
              = CLng(dicStore.Item(vntData(1, 1)))
            'Sheet1のi行D、E列をコピーして、店舗の行位置に張りつけ
            .Cells(i, "D").Resize(, 2).Copy _
              Worksheets(lngSheetNo).Cells(lngStoreNo, "Q")
          End If
        End If
      End If
    Next i
  End With
 
  Beep
  MsgBox "処理が完了しました"
 
ExitHandler:
 
  '画面更新を再開
  Application.ScreenUpdating = True
 
  'Dictionaryを破棄
  Set dicSheets = Nothing
  Set dicStore = Nothing

End Sub

Private Function DateCheck(ByVal _
          vntValue As Variant) As Boolean

'  日付のチェック

  If vntValue = "" Then
    Exit Function
  End If
  If Len(vntValue) <> 8 Then
    Exit Function
  End If
  vntValue = Left(vntValue, 4) _
        & "/" & Mid(vntValue, 5, 2) _
          & "/" & Right(vntValue, 2)
  If IsDate(vntValue) Then
    DateCheck = True
  End If
 
End Function

Private Function MakeSheetsIndex(dicSheets As Object, _
              lngSheetNo As Long) As Boolean

'  B1セルに日付の有るシートのIndexを作成


  Dim i As Long
  Dim vntDate As Variant
 
  'ワークシートコレクションに就いて
  With Worksheets
    'コレクションの先頭から終りまで繰り返し
    For i = 1 To .Count
      'シートiのE1の値を取得
      vntDate = .Item(i).Cells(1, "E").Value  ←ここです
      'もし、日付と認められるなら
      If DateCheck(vntDate) Then
        'シートのIndexにこの日付が有る場合
        If dicSheets.Exists(vntDate) Then
          Beep
          MsgBox "同一の日付が有ります"
          Exit Function
        '日付が無い場合
        Else
          'Indexにこの日付とシート番号を追加
          dicSheets.Add vntDate, i
          '最初にIndexに追加されたシート番号を保存
          If lngSheetNo = 0 Then
            lngSheetNo = i
          End If
        End If
      End If
    Next i
  End With
 
  MakeSheetsIndex = True
 
End Function

Private Function MakeStoreIndex(dicStore As Object, _
              lngSheetNo As Long) As Boolean

'  店舗のIndexを作成

  '店舗データの先頭行位置を定数宣言
  Const clngDataTop As Long = 5
 
  Dim i As Long
  Dim vntData As Variant
 
  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)
    '店舗名を配列に取得
    vntData = Range(.Cells(clngDataTop, "A"), _
          .Cells(clngSheetEnd, "A").End(xlUp)).Value
  End With
  '店舗Indexに就いて
  With dicStore
    '店舗名の先頭から終まで繰り返し
    For i = 1 To UBound(vntData, 1)
      'Indexにi番目の店舗名が有るなら
      If .Exists(vntData(i, 1)) Then
        Beep
        MsgBox "同一の店名が有ります"
        Exit Function
      'i番目の店舗名が無いなら
      Else
        'Indexに店舗名と行位置を追加
        .Add vntData(i, 1), i + clngDataTop - 1
      End If
    Next i
  End With

  MakeStoreIndex = True
 
End Function

【13618】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/9(日) 20:44 -

引用なし
パスワード
   修正個所は、私が指定した場所で修正も合っています
とすると、後こう言う現象が考えられるのは、
転記先のシートのE1セルに有る日付が臭い所だと思います
例えば、「20040401」と見えても実際は前、後にスペースが入っていて
「20040401  」とか「  20040401」とか「 20040401 」に成っている可能性が有りませんか?
何か、前の質問の時もそんなことがありませんでしたっけ?
一応、こう成っている場合の対策を取ります
以下の様に、コードを追加して下さい、「集合表」のB列も成っている可能性が有りますので
其方も対策します

追加の場所は二ヶ所で、日付の前後のスペースを取ります
ただし、ワークシート上は変化しませんので宜しく

1つは、「Sub Classification」の

      'もし、i行B列のセル値が日付と認識されるなら
      vntData(1, 2) = Trim(vntData(1, 2)) '★この行追加
      If DateCheck(vntData(1, 2)) Then
        'もし、シートのIndexにこの日付が有るなら

部分を修正

もう一つは、「Function MakeSheetsIndex」の

      'シートiのB1の値を取得
      vntDate = .Item(i).Cells(1, "E").Value
      vntDate = Trim(vntDate) '★この行追加
      'もし、日付と認められるなら

の部分を修正して下さい

【13620】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/9(日) 21:21 -

引用なし
パスワード
   ▼Hirofumi さん,こんばんは。もう、ご飯の時間なのに、色々とご面倒おかけしてすみません。ご指摘の部分について、訂正しましたが、やはり、「インデックスが有効ではありまん」というエラーがでます。
転記先のシートのE1セルの日付はたしかに「   20040401」となっており、そのセル幅が広く、数値が右寄せのため、スペースが空いています。
そういえば、そのセルE1には、「=B1」という数式が入っています。
B〜Dの結合セルに「平成16年4月1日」という文字が入っており、それをユーザー定義で8桁の数値へ変換しています。これは、最初の質問の際に、ご提示したモジュールで、検索条件であるシート1の日付(20040401などです)に合致する値を検索するため、各シートのB〜Dの結合セルだと、うまく検索できなかったので、これを、E1へ8桁に変換したあと、検索していたためです。これも起因しているのでしょうか?

【13664】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/10(月) 20:06 -

引用なし
パスワード
   ▼ハルコ さん:
>▼Hirofumi さん,こんばんは。もう、ご飯の時間なのに、色々とご面倒おかけしてすみません。ご指摘の部分について、訂正しましたが、やはり、「インデックスが有効ではありまん」というエラーがでます。
>転記先のシートのE1セルの日付はたしかに「   20040401」となっており、そのセル幅が広く、数値が右寄せのため、スペースが空いています。
>そういえば、そのセルE1には、「=B1」という数式が入っています。
>B〜Dの結合セルに「平成16年4月1日」という文字が入っており、それをユーザー定義で8桁の数値へ変換しています。これは、最初の質問の際に、ご提示したモジュールで、検索条件であるシート1の日付(20040401などです)に合致する値を検索するため、各シートのB〜Dの結合セルだと、うまく検索できなかったので、これを、E1へ8桁に変換したあと、検索していたためです。これも起因しているのでしょうか?

結局、転記先のシートのE1セルには何が入っているのですか?
ユーザー定義への式が入っているのですか?
でも、「=B1」と言う式なら、B1へのセル参照ですよね?
また、「それをユーザー定義で8桁の数値へ変換しています。」と有りますが
ユーザー定義関数はどの様な物ですか?

要は、これが解らないとこのコードは上手く動かないと思います

【13666】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/10(月) 21:24 -

引用なし
パスワード
   ▼Hirofumi さん、こんばんは。
転記先シートについて、説明させていただきます。
まず、セルB1にはユーザー定義関数「ggge"年"m"月"d"日"("aaa")"」により「平成16年4月1日」と現れるようになってます。そして、セルE1にはB1へセル参照式である「=B1」が入っており、なおかつユーザー定義で「yyyymmdd」が設定されています。結果、「20040401」という表示になります。

【13668】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/10(月) 21:48 -

引用なし
パスワード
   解りました、転記先のE1は、シリアル値で文字列では有りません
Sheet1のB列の日付は、完全に文字列なんですね?
例「20040401」と入っているんですね!

だとすると、大分コードを書き換える様なので全文を載せますので
此れで試して下さい


Option Explicit

'シートの最終行位置を定数として宣言
Const clngSheetEnd As Long = 65536

Public Sub Classification2()

  'Sheet1のデータ先頭行を定数として宣言
  Const clngDataTop As Long = 3

  Dim i As Long
  Dim lngDataEnd As Long
  Dim dicSheets As Object
  Dim dicStore As Object
  Dim vntData As Variant
  Dim lngSheetNo As Long
  Dim lngStoreNo As Long
  Dim blnCopy As Boolean
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'シートのIndexをDictionaryとして取得
  Set dicSheets _
      = CreateObject("Scripting.Dictionary")
  '店のIndexをDictionaryとして取得
  Set dicStore _
      = CreateObject("Scripting.Dictionary")
  
  'シートのIndexを作成
  If Not MakeSheetsIndex(dicSheets, lngSheetNo) Then
    GoTo ExitHandler
  End If
  
  '店のIndexを作成
  If Not MakeStoreIndex(dicStore, lngSheetNo) Then
    GoTo ExitHandler
  End If
  
  'データの有るシートに就いて
  With Worksheets("Sheet1")
    'データの最終行を取得
    lngDataEnd = .Cells(clngSheetEnd, "A").End(xlUp).Row
    'データの有る先頭行〜最終行まで繰り返し
    For i = clngDataTop To lngDataEnd
      '配列にi行のA、B列を取得
      vntData = .Cells(i, 1).Resize(, 2).Value
      'もし、i行B列のセル値が日付と認識されるなら
      If DateCheck(vntData(1, 2)) Then
        'もし、シートのIndexにこの日付が有るなら
        If dicSheets.Exists(vntData(1, 2)) Then
          'シートの番号を取得
          lngSheetNo _
            = CLng(dicSheets.Item(vntData(1, 2)))
          'コピーフラグをTrueに
          blnCopy = True
        '日付が無いなら
        Else
          '当月分と認めず、このグループを無視
          MsgBox vntData(1, 2) & "、他の月の分です。"
          'コピーフラグをFalseに
          blnCopy = False
        End If
      'i行B列のセル値が日付と認識されないなら
      Else
        'コピーフラグがTrueなら
        If blnCopy Then
          '店舗Indexにi行A列の値が有るなら
          If dicStore.Exists(vntData(1, 1)) Then
            '店舗の行位置を取得
            lngStoreNo _
              = CLng(dicStore.Item(vntData(1, 1)))
            'Sheet1のi行D、E列をコピーして、店舗の行位置に張りつけ
            .Cells(i, "D").Resize(, 2).Copy _
              Worksheets(lngSheetNo).Cells(lngStoreNo, "Q")
          End If
        End If
      End If
    Next i
  End With
  
  Beep
  MsgBox "処理が完了しました"
  
ExitHandler:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  'Dictionaryを破棄
  Set dicSheets = Nothing
  Set dicStore = Nothing

End Sub

Private Function DateCheck(vntValue As Variant) As Boolean

'  日付のチェック

  Dim vntResult As Variant
  
  If vntValue = "" Then
    Exit Function
  End If
  vntValue = Trim(vntValue)
  If Len(vntValue) <> 8 Then
    Exit Function
  End If
  vntResult = Left(vntValue, 4) _
        & "/" & Mid(vntValue, 5, 2) _
          & "/" & Right(vntValue, 2)
  If IsDate(vntResult) Then
    DateCheck = True
    vntValue = DateValue(vntResult)
  End If
  
End Function

Private Function MakeSheetsIndex(dicSheets As Object, _
              lngSheetNo As Long) As Boolean

'  B1セルに日付の有るシートのIndexを作成


  Dim i As Long
  Dim vntDate As Variant
  
  'ワークシートコレクションに就いて
  With Worksheets
    'コレクションの先頭から終りまで繰り返し
    For i = 1 To .Count
      'シートiのB1の値を取得
      vntDate = .Item(i).Cells(1, "E").Value
      'もし、日付と認められるなら
      If IsDate(vntDate) Then
        'シートのIndexにこの日付が有る場合
        If dicSheets.Exists(vntDate) Then
          Beep
          MsgBox "同一の日付が有ります"
          Exit Function
        '日付が無い場合
        Else
          'Indexにこの日付とシート番号を追加
          dicSheets.Add vntDate, i
          '最初にIndexに追加されたシート番号を保存
          If lngSheetNo = 0 Then
            lngSheetNo = i
          End If
        End If
      End If
    Next i
  End With
  
  MakeSheetsIndex = True
  
End Function

Private Function MakeStoreIndex(dicStore As Object, _
              lngSheetNo As Long) As Boolean

'  店舗のIndexを作成

  '店舗データの先頭行位置を定数宣言
  Const clngDataTop As Long = 5
  
  Dim i As Long
  Dim vntData As Variant
  
  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)
    '店舗名を配列に取得
    vntData = Range(.Cells(clngDataTop, "A"), _
          .Cells(clngSheetEnd, "A").End(xlUp)).Value
  End With
  '店舗Indexに就いて
  With dicStore
    '店舗名の先頭から終まで繰り返し
    For i = 1 To UBound(vntData, 1)
      'Indexにi番目の店舗名が有るなら
      If .Exists(vntData(i, 1)) Then
        Beep
        MsgBox "同一の店名が有ります"
        Exit Function
      'i番目の店舗名が無いなら
      Else
        'Indexに店舗名と行位置を追加
        .Add vntData(i, 1), i + clngDataTop - 1
      End If
    Next i
  End With

  MakeStoreIndex = True
  
End Function

【13669】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/10(月) 23:12 -

引用なし
パスワード
   ▼Hirofumi さん、こんばんは。度々、申し訳ありません(TT)
 ご指示のとおり試しました。エラーは出ませんでした。しかし、以下の「←」の部分について、「同一の店名があります」というメッセージが出てしまい、転記がなされません。どのようにしたら良いのでしょうか?

>Option Explicit
>
>'シートの最終行位置を定数として宣言
>Const clngSheetEnd As Long = 65536
>
>Public Sub Classification2()
>
>  'Sheet1のデータ先頭行を定数として宣言
>  Const clngDataTop As Long = 3
>
>  Dim i As Long
>  Dim lngDataEnd As Long
>  Dim dicSheets As Object
>  Dim dicStore As Object
>  Dim vntData As Variant
>  Dim lngSheetNo As Long
>  Dim lngStoreNo As Long
>  Dim blnCopy As Boolean
>  
>  '画面更新を停止
>  Application.ScreenUpdating = False
>  
>  'シートのIndexをDictionaryとして取得
>  Set dicSheets _
>      = CreateObject("Scripting.Dictionary")
>  '店のIndexをDictionaryとして取得
>  Set dicStore _
>      = CreateObject("Scripting.Dictionary")
>  
>  'シートのIndexを作成
>  If Not MakeSheetsIndex(dicSheets, lngSheetNo) Then
>    GoTo ExitHandler
>  End If
>  
>  '店のIndexを作成
>  If Not MakeStoreIndex(dicStore, lngSheetNo) Then
>    GoTo ExitHandler
>  End If
>  
>  'データの有るシートに就いて
>  With Worksheets("Sheet1")
>    'データの最終行を取得
>    lngDataEnd = .Cells(clngSheetEnd, "A").End(xlUp).Row
>    'データの有る先頭行〜最終行まで繰り返し
>    For i = clngDataTop To lngDataEnd
>      '配列にi行のA、B列を取得
>      vntData = .Cells(i, 1).Resize(, 2).Value
>      'もし、i行B列のセル値が日付と認識されるなら
>      If DateCheck(vntData(1, 2)) Then
>        'もし、シートのIndexにこの日付が有るなら
>        If dicSheets.Exists(vntData(1, 2)) Then
>          'シートの番号を取得
>          lngSheetNo _
>            = CLng(dicSheets.Item(vntData(1, 2)))
>          'コピーフラグをTrueに
>          blnCopy = True
>        '日付が無いなら
>        Else
>          '当月分と認めず、このグループを無視
>          MsgBox vntData(1, 2) & "、他の月の分です。"
>          'コピーフラグをFalseに
>          blnCopy = False
>        End If
>      'i行B列のセル値が日付と認識されないなら
>      Else
>        'コピーフラグがTrueなら
>        If blnCopy Then
>          '店舗Indexにi行A列の値が有るなら
>          If dicStore.Exists(vntData(1, 1)) Then
>            '店舗の行位置を取得
>            lngStoreNo _
>              = CLng(dicStore.Item(vntData(1, 1)))
>            'Sheet1のi行D、E列をコピーして、店舗の行位置に張りつけ
>            .Cells(i, "D").Resize(, 2).Copy _
>              Worksheets(lngSheetNo).Cells(lngStoreNo, "Q")
>          End If
>        End If
>      End If
>    Next i
>  End With
>  
>  Beep
>  MsgBox "処理が完了しました"
>  
>ExitHandler:
>  
>  '画面更新を再開
>  Application.ScreenUpdating = True
>  
>  'Dictionaryを破棄
>  Set dicSheets = Nothing
>  Set dicStore = Nothing
>
>End Sub
>
>Private Function DateCheck(vntValue As Variant) As Boolean
>
>'  日付のチェック
>
>  Dim vntResult As Variant
>  
>  If vntValue = "" Then
>    Exit Function
>  End If
>  vntValue = Trim(vntValue)
>  If Len(vntValue) <> 8 Then
>    Exit Function
>  End If
>  vntResult = Left(vntValue, 4) _
>        & "/" & Mid(vntValue, 5, 2) _
>          & "/" & Right(vntValue, 2)
>  If IsDate(vntResult) Then
>    DateCheck = True
>    vntValue = DateValue(vntResult)
>  End If
>  
>End Function
>
>Private Function MakeSheetsIndex(dicSheets As Object, _
>              lngSheetNo As Long) As Boolean
>
>'  B1セルに日付の有るシートのIndexを作成
>
>
>  Dim i As Long
>  Dim vntDate As Variant
>  
>  'ワークシートコレクションに就いて
>  With Worksheets
>    'コレクションの先頭から終りまで繰り返し
>    For i = 1 To .Count
>      'シートiのB1の値を取得
>      vntDate = .Item(i).Cells(1, "E").Value
>      'もし、日付と認められるなら
>      If IsDate(vntDate) Then
>        'シートのIndexにこの日付が有る場合
>        If dicSheets.Exists(vntDate) Then
>          Beep
>          MsgBox "同一の日付が有ります"
>          Exit Function
>        '日付が無い場合
>        Else
>          'Indexにこの日付とシート番号を追加
>          dicSheets.Add vntDate, i
>          '最初にIndexに追加されたシート番号を保存
>          If lngSheetNo = 0 Then
>            lngSheetNo = i
>          End If
>        End If
>      End If
>    Next i
>  End With
>  
>  MakeSheetsIndex = True
>  
>End Function
>
>Private Function MakeStoreIndex(dicStore As Object, _
>              lngSheetNo As Long) As Boolean
>
>'  店舗のIndexを作成
>
>  '店舗データの先頭行位置を定数宣言
>  Const clngDataTop As Long = 5
>  
>  Dim i As Long
>  Dim vntData As Variant
>  
>  '最初にIndexに追加されたシート番号に就いて
>  With Worksheets(lngSheetNo)
>    '店舗名を配列に取得
>    vntData = Range(.Cells(clngDataTop, "A"), _
>          .Cells(clngSheetEnd, "A").End(xlUp)).Value
>  End With
>  '店舗Indexに就いて
>  With dicStore
>    '店舗名の先頭から終まで繰り返し
>    For i = 1 To UBound(vntData, 1)
>      'Indexにi番目の店舗名が有るなら
>      If .Exists(vntData(i, 1)) Then
>        Beep
>        MsgBox "同一の店名が有ります"    ←ここです
>        Exit Function
>      'i番目の店舗名が無いなら
>      Else
>        'Indexに店舗名と行位置を追加
>        .Add vntData(i, 1), i + clngDataTop - 1
>      End If
>    Next i
>  End With
>
>  MakeStoreIndex = True
>  
>End Function

【13719】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/11(火) 20:18 -

引用なし
パスワード
   此れを起こすのは、転記先のシートの一番左のシートの店舗が重複している場合
若しくは、転記先シート以外のシートで、E1セルに日付が入っているシートが有る場合です
多分、2つ目の可能性が高いと思います
調べて見て下さい
この場合、シート名が解れば回避する方法も有ります
転記先のシート以外は、確か5シートぐらいでしたか?

【13721】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/11(火) 21:10 -

引用なし
パスワード
   特定のシートを明示的に除外する様にコードを変更します
「Function MakeSheetsIndex」プロシージャを以下の様に変更して下さい

Private Function MakeSheetsIndex(dicSheets As Object, _
              lngSheetNo As Long) As Boolean

'  B1セルに日付の有るシートのIndexを作成


  Dim i As Long
  Dim j As Long '★この行追加
  Dim vntDate As Variant
  Dim vntExclude As Variant '★この行追加
  Dim blnExclude As Boolean '★この行追加
  
  '除外するシート名を配列に(""で括り「,」で区切って羅列)
  vntExclude = Array("集計表", "Sheet32") '★この行追加
  
  'ワークシートコレクションに就いて
  With Worksheets
    'コレクションの先頭から終りまで繰り返し
    For i = 1 To .Count
      '除外フラグをFalseに
      blnExclude = False '★この行追加
      '除外するシート名の先頭〜最終まで繰り返し
      For j = 0 To UBound(vntExclude) '★この行追加
        'もしi番目のシート名が除外するシート名と一致するなら
        If .Item(i).Name = vntExclude(j) Then '★この行追加
          ''除外フラグをTrueの
          blnExclude = True '★この行追加
          'Forを抜ける
          Exit For '★この行追加
        End If '★この行追加
      Next j '★この行追加
      '除外するシートで無い場合
      If Not blnExclude Then '★この行追加
        'シートiのB1の値を取得
        vntDate = .Item(i).Cells(1, "E").Value
        'もし、日付と認められるなら
        If IsDate(vntDate) Then
          'シートのIndexにこの日付が有る場合
          If dicSheets.Exists(vntDate) Then
            Beep
            MsgBox "同一の日付が有ります"
            Exit Function
          '日付が無い場合
          Else
            'Indexにこの日付とシート番号を追加
            dicSheets.Add vntDate, i
            '最初にIndexに追加されたシート番号を保存
            If lngSheetNo = 0 Then
              lngSheetNo = i
            End If
          End If
        End If '★この行追加
      End If
    Next i
  End With
  
  MakeSheetsIndex = True
  
End Function

明示的に除外するシート名を、以下の部分で指定して下さい
尚、シート名は""で括り「,」で区切って羅列して下さい

  '除外するシート名を配列に(""で括り「,」で区切って羅列)
  vntExclude = Array("集計表", "Sheet32") '★この行追加

【13722】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/11(火) 22:24 -

引用なし
パスワード
   ▼Hirofumi さん、こんばんは。
 特定のシートを明示的に除外するコードを変更し、除外するシート名を羅列しましたが、やはり同一のメッセージがでます。
 
 あの…、今気づいたのですが、日別シート(1〜31日)のセルB5〜B37以外に
 同一表内のセルH77〜H109にも、同じ配列で、セルB5〜B37と同一の店舗名があり ました。恐らく、これが原因だと思います。又、集計表の店名は、「A店」「D店」などと「〜店」と入力されていますが、日別シートの店舗名は、「〜店」がついておらず(全部ではないです。数個の店については、「〜店」がついています)「A」「D」などと入力されているのです。
 申し訳ありません。

【13755】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/12(水) 19:50 -

引用なし
パスワード
   > あの…、今気づいたのですが、日別シート(1〜31日)のセルB5〜B37以外に
> 同一表内のセルH77〜H109にも、同じ配列で、セルB5〜B37と同一の店舗名がありました。
>恐らく、これが原因だと思います。
>又、集計表の店名は、「A店」「D店」などと「〜店」と入力されていますが、
>日別シートの店舗名は、「〜店」がついておらず(全部ではないです。数個の店については、
>「〜店」がついています)「A」「D」などと入力されているのです。

セルH77〜H109の店舗名は、関係無いと思います
これは、私のボケです、私は転記先シートのA列に店舗名が有ると思っていました
B列なんですね
後、集計表の店舗は「店」が必ず入っているのですね!

此れを修正します
「Function MakeStoreIndex」を以下の様に修正して下さい

Private Function MakeStoreIndex(dicStore As Object, _
              lngSheetNo As Long) As Boolean

'  店舗のIndexを作成

  '店舗データの先頭行位置を定数宣言
  Const clngDataTop As Long = 5
  
  Dim i As Long
  Dim vntData As Variant
  
  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)
    '店舗名を配列に取得
    vntData = Range(.Cells(clngDataTop, "B"), _
          .Cells(clngSheetEnd, "B").End(xlUp)).Value '★この行修正
  End With
  '店舗Indexに就いて
  With dicStore
    '店舗名の先頭から終まで繰り返し
    For i = 1 To UBound(vntData, 1)
      '店舗名に「店」が無い場合、「店」を追加する
      If Right(vntData(i, 1), 1) <> "店" Then '★この行追加
        vntData(i, 1) = vntData(i, 1) & "店" '★この行追加
      End If '★この行追加
      'Indexにi番目の店舗名が有るなら
      If .Exists(vntData(i, 1)) Then
        Beep
        MsgBox "同一の店名が有ります"
        Exit Function
      'i番目の店舗名が無いなら
      Else
        'Indexに店舗名と行位置を追加
        .Add vntData(i, 1), i + clngDataTop - 1
      End If
    Next i
  End With

  MakeStoreIndex = True
  
End Function

【13760】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/12(水) 22:17 -

引用なし
パスワード
   ▼Hirofumi さん、こんばんは。ご指摘のとおりコードを入力しましたが、だめみたいです。私もコードの内容について勉強しているのですが、わかりません。
それで、参考までに今現在のコードを添付致します。それでも判明できなかったら、非常に残念ですが、ここであきらめるしかないです。これ以上、ご迷惑をおかけすることはできないので、後は、私で、Hirohumiさんのコードを元に勉強して、
解明してみます。

Option Explicit

'シートの最終行位置を定数として宣言
Const clngSheetEnd As Long = 65536

Public Sub Classification2()

  'Sheet1のデータ先頭行を定数として宣言
  Const clngDataTop As Long = 3

  Dim i As Long
  Dim lngDataEnd As Long
  Dim dicSheets As Object
  Dim dicStore As Object
  Dim vntData As Variant
  Dim lngSheetNo As Long
  Dim lngStoreNo As Long
  Dim blnCopy As Boolean
 
  '画面更新を停止
  Application.ScreenUpdating = False
 
  'シートのIndexをDictionaryとして取得
  Set dicSheets _
      = CreateObject("Scripting.Dictionary")
  '店のIndexをDictionaryとして取得
  Set dicStore _
      = CreateObject("Scripting.Dictionary")
 
  'シートのIndexを作成
  If Not MakeSheetsIndex(dicSheets, lngSheetNo) Then
    GoTo ExitHandler
  End If
 
  '店のIndexを作成
  If Not MakeStoreIndex(dicStore, lngSheetNo) Then
    GoTo ExitHandler
  End If
 
  'データの有るシートに就いて
  With Worksheets("集計表")
    'データの最終行を取得
    lngDataEnd = .Cells(clngSheetEnd, "A").End(xlUp).Row
    'データの有る先頭行〜最終行まで繰り返し
    For i = clngDataTop To lngDataEnd
      '配列にi行のA、B列を取得
      vntData = .Cells(i, 1).Resize(, 2).Value
      'もし、i行B列のセル値が日付と認識されるなら
      If DateCheck(vntData(1, 2)) Then
        'もし、シートのIndexにこの日付が有るなら
        If dicSheets.Exists(vntData(1, 2)) Then
          'シートの番号を取得
          lngSheetNo _
            = CLng(dicSheets.Item(vntData(1, 2)))
          'コピーフラグをTrueに
          blnCopy = True
        '日付が無いなら
        Else
          '当月分と認めず、このグループを無視
          MsgBox vntData(1, 2) & "、他の月の分です。"
          'コピーフラグをFalseに
          blnCopy = False
        End If
      'i行B列のセル値が日付と認識されないなら
      Else
        'コピーフラグがTrueなら
        If blnCopy Then
          '店舗Indexにi行A列の値が有るなら
          If dicStore.Exists(vntData(1, 1)) Then
            '店舗の行位置を取得
            lngStoreNo _
              = CLng(dicStore.Item(vntData(1, 1)))
            'Sheet1のi行D、E列をコピーして、店舗の行位置に張りつけ
            .Cells(i, "D").Resize(, 2).Copy _
              Worksheets(lngSheetNo).Cells(lngStoreNo, "Q")
          End If
        End If
      End If
    Next i
  End With
 
  Beep
  MsgBox "処理が完了しました"
 
ExitHandler:
 
  '画面更新を再開
  Application.ScreenUpdating = True
 
  'Dictionaryを破棄
  Set dicSheets = Nothing
  Set dicStore = Nothing

End Sub

Private Function DateCheck(vntValue As Variant) As Boolean

'  日付のチェック

  Dim vntResult As Variant
 
  If vntValue = "" Then
    Exit Function
  End If
  vntValue = Trim(vntValue)
  If Len(vntValue) <> 8 Then
    Exit Function
  End If
  vntResult = Left(vntValue, 4) _
        & "/" & Mid(vntValue, 5, 2) _
          & "/" & Right(vntValue, 2)
  If IsDate(vntResult) Then
    DateCheck = True
    vntValue = DateValue(vntResult)
  End If
 
End Function

Private Function MakeSheetsIndex(dicSheets As Object, _
              lngSheetNo As Long) As Boolean

'  B1セルに日付の有るシートのIndexを作成


  Dim i As Long
  Dim j As Long '★この行追加
  Dim vntDate As Variant
  Dim vntExclude As Variant '★この行追加
  Dim blnExclude As Boolean '★この行追加
 
  '除外するシート名を配列に(""で括り「,」で区切って羅列)
  vntExclude = Array("シート1", "シート2", "シート3", "シート4", "シート5", "シート37", "シート38") '★この行追加
 
  'ワークシートコレクションに就いて
  With Worksheets
    'コレクションの先頭から終りまで繰り返し
    For i = 1 To .Count
      '除外フラグをFalseに
      blnExclude = False '★この行追加
      '除外するシート名の先頭〜最終まで繰り返し
      For j = 0 To UBound(vntExclude) '★この行追加
        'もしi番目のシート名が除外するシート名と一致するなら
        If .Item(i).Name = vntExclude(j) Then '★この行追加
          ''除外フラグをTrueの
          blnExclude = True '★この行追加
          'Forを抜ける
          Exit For '★この行追加
        End If '★この行追加
      Next j '★この行追加
      '除外するシートで無い場合
      If Not blnExclude Then '★この行追加
        'シートiのE1の値を取得
        vntDate = .Item(i).Cells(1, "E").Value
        'もし、日付と認められるなら
        If IsDate(vntDate) Then
          'シートのIndexにこの日付が有る場合
          If dicSheets.Exists(vntDate) Then
            Beep
            MsgBox "同一の日付が有ります"
            Exit Function
          '日付が無い場合
          Else
            'Indexにこの日付とシート番号を追加
            dicSheets.Add vntDate, i
            '最初にIndexに追加されたシート番号を保存
            If lngSheetNo = 0 Then
              lngSheetNo = i
            End If
          End If
        End If '★この行追加
      End If
    Next i
  End With
 
  MakeSheetsIndex = True
 
End Function


Private Function MakeStoreIndex(dicStore As Object, _
              lngSheetNo As Long) As Boolean

'  店舗のIndexを作成

  '店舗データの先頭行位置を定数宣言
  Const clngDataTop As Long = 5
 
  Dim i As Long
  Dim vntData As Variant
 
  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)
    '店舗名を配列に取得
    vntData = Range(.Cells(clngDataTop, "B"), _
          .Cells(clngSheetEnd, "B").End(xlUp)).Value '★この行修正
  End With
  '店舗Indexに就いて
  With dicStore
    '店舗名の先頭から終まで繰り返し
    For i = 1 To UBound(vntData, 1)
      '店舗名に「店」が無い場合、「店」を追加する
      If Right(vntData(i, 1), 1) <> "店" Then '★この行追加
        vntData(i, 1) = vntData(i, 1) & "店" '★この行追加
      End If '★この行追加
      'Indexにi番目の店舗名が有るなら
      If .Exists(vntData(i, 1)) Then
        Beep
        MsgBox "同一の店名が有ります"
        Exit Function
      'i番目の店舗名が無いなら
      Else
        'Indexに店舗名と行位置を追加
        .Add vntData(i, 1), i + clngDataTop - 1
      End If
    Next i
  End With

  MakeStoreIndex = True
 
End Function

【13801】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/13(木) 21:49 -

引用なし
パスワード
   >▼Hirofumi さん、こんばんは。ご指摘のとおりコードを入力しましたが、
>だめみたいです。私もコードの内容について勉強しているのですが、わかりません。
>それで、参考までに今現在のコードを添付致します。それでも判明できなかったら、
>非常に残念ですが、ここであきらめるしかないです。
>これ以上、ご迷惑をおかけすることはできないので、
>後は、私で、Hirohumiさんのコードを元に勉強して、
>解明してみます。

別に、大して迷惑では有りませんが、土日ぐらいしか頻繁に回答できなくて
ご迷惑をお掛けしています
ただ、私もこのコードが動かないのが癪に障りますので
もし、ハルコさんに試して見る気が有れば、デバグの方法をお教えしますので
此れを試して見て下さい

現在の状態は、「同一の店名が有ります」と言う所で引っ掛かっているのですよね?
これは、どのシートの店舗名を読んでこうなって居るのかを調べます

1、コードの実行を途中で止めるので
 先ず、「Sub Classification2」の中の

  '画面更新を停止
'  Application.ScreenUpdating = False

  '画面更新を再開
'  Application.ScreenUpdating = True

 をコメントアウトして下さい
 コメントアウトとは、上記の様に先頭に"'"アポストロフィーを付け
 コメント行にする事です

2、次に、「Function MakeStoreIndex」プロシージャを出します
 
  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)

 の位置で、Worksheets(lngSheetNo)をドラッグして反転表示にします

3、此れを、マウスでポイントして、右クリックします
 メニューが出ますので、ウォッチ式の追加をクリックします
 ウォッチ式の追加のダイアログが出て、式の所に

 Worksheets(lngSheetNo)

 が入って表示されるはずです
 此れを
 
 Worksheets(lngSheetNo).Name

 に替え、Okを出します
 画面下側に、ウォッチウインドウが出て、ここに、今入れた「Worksheets(lngSheetNo).Name」
 が表示されているはずです

4、同様に「For i = 」のiを反転表示して、ウォッチ式の追加を行い、ウォッチウインドウに追加します
5、同様に、「'店舗名の先頭から終まで繰り返し」以下のコード中の「vntData(i, 1)」も、
 ウォッチウインドウに追加します
6、次に、

  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)

 のWithの左側のウィンドウ枠の幅広の部分をクリックします、
 枠に●が表示され、「With Worksheets(lngSheetNo)」が反転表示されます
 私の環境では、反転表示、●共に茶色の色が付いています
 これは、ここにブレークポイントを設定したと言います
7、これで準備が出来ました、表示をVBEからシートにし、マクロを実行します
8、マクロを実行すると、先ほど設定したブレークポイントの位置で実行が中断します
 この時、ウォッチウインドウの「Worksheets(lngSheetNo).Name」の右側の値の所を見ると
 店舗を読みに行っているシートのシート名が表示されています
 まず、此れが転記先のシートの1枚かどうか確認して下さい
9、次に、ファンクションキーのF8を押すと、私の環境では、黄色の反転表示が現れます
 此れは、スッテプ実行と言って、1行づつコードを実行していきます
 F8を何回か押して、黄色の反転表示を「If Right(vntData(i, 1), 1) <> "店" Then」
 の所まで持って行きます、この時、ウォッチウインドウのiの値、vntData(i, 1)の値
 を見て下さい、この様にF8を押す毎に1行づつ実行され、黄色の反転表示の前の行まで
 に変更された、iの値とvntData(i, 1)の値を見ることが出来ます
10、F8を繰り返していくと、何処かで「Beep」の所に反転表示が移ります
 この時のiの値、vntData(i, 1)の値がハルコさんの心当たりの有る値かどうか確認してください
11、もし、シート名が転記先シートの1枚で無ければ、そのシートのE1の日付が有るはずです
 また、シート名が転記先シートの1枚で有れば、vntData(i, 1)の値が店舗名で有るのかを
 確認して下さい、有るなら、vntData(i, 1)の値に重複が有るか確認して下さい
12、ここら辺の事が解ったら報告して下さい
13、全てを確認したら、VBEのメニュバーの「実行」→「リセット」を選択して実行を中止します
 次に、VBEのメニュバーの「デバッグ」→「すべてのブレークポントの解除」を選択して
 すべてのブレークポントを解除して置きます

【13845】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/15(土) 1:31 -

引用なし
パスワード
   ▼Hirofumi さん、こんばんは。
 早速、ご指摘の内容について確認しました。こういう機能があるとは驚きました。すぐに、不具合な箇所がわかりました。ですが、対処の仕方がわかりません。またまた、ご教授願います。ウォッチウインドウの値について、以下のとおり記述します。

1.    まず、「Worksheets(lngSheetNo).Name」は、最初のシートの検索では全て「1」です。つまり、全て転記先のシート名でしたので、これは問題ないかと思われます。ウォッチウィンドウに追加したデータは、以下の7箇所の下線部分です。

  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)  
    '店舗名を配列に取得
    vntData = Range(.Cells(clngDataTop, "B"), _
          .Cells(clngSheetEnd, "B").End(xlUp)).Value '★この行修正
  End With
  '店舗Indexに就いて
  With dicStore
    '店舗名の先頭から終まで繰り返し
    For i = 1 To UBound(vntData, 1)
      '店舗名に「店」が無い場合、「店」を追加する
      If Right(vntData(i, 1), 1) <> "店" Then '★この行追加
        vntData(i, 1) = vntData(i, 1) & "支店" '★この行追加
      End If '★この行追加
      'Indexにi番目の店舗名が有るなら
      If .Exists(vntData(i, 1)) Then
        Beep
        MsgBox "同一の店名が有ります"
        Exit Function
      'i番目の店舗名が無いなら
      Else
        'Indexに店舗名と行位置を追加
        .Add vntData(i, 1), i + clngDataTop - 1
      End If
    Next i
  End With

2.「i」の値は、1〜36までで、ウォッチウィンドウに追加したデータの値は、以
下のとおりです。以下の構文で表している1.〜8.の時の「vntData(i, 1)」値をその下に記載しています。なお、「Beep」はi=36で反転表示になりました。その内容も追記しています。(店舗の数は、全部で33店舗。a店〜bg店までです。)
    '店舗名の先頭から終まで繰り返し
    For i = 1 To UBound(vntData, 1) 
      '店舗名に「店」が無い場合、「店」を追加する
      If Right(vntData(i, 1), 1) <> "店" Then '★この行追加 ・・・1.
        vntData(i, 1) = vntData(i, 1) & "店" '★この行追加 ・・・2.
      End If '★この行追加 ・・・3.
      'Indexにi番目の店舗名が有るなら
      If .Exists(vntData(i, 1)) Then ・・・4.
        Beep 
        MsgBox "同一の店名が有ります" 
        Exit Function
      'i番目の店舗名が無いなら
      Else ・・・5.
        'Indexに店舗名と行位置を追加
        .Add vntData(i, 1), i + clngDataTop &#8211; 1 ・・・6.
      End If ・・・7.
    Next i ・・・8.


       1.〜2.  3.〜8.   「Beep」の値
  i=1   a     a店    −
  i=2   b      b店    −
  i=3   c      c店    −
          ・
          ・
          ・
  i=33  bg     bg店   −
  i=34  合計     合計店  −
  i=35  Empty値   店    −
  i=36  Empty値   店    店

【13849】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/15(土) 7:31 -

引用なし
パスワード
   > 早速、ご指摘の内容について確認しました。
>こういう機能があるとは驚きました。すぐに、不具合な箇所がわかりました。
>ですが、対処の仕方がわかりません。

不具合の箇所が解って善かったですね?
この様な操作を、デバグ(バグ取り)と言ってコードを作る上ではしょちゅう行います
デバグ方法は人に因り、場合に因り違います
ただ、此れが出来ないとコードは組めません
Helpで、デバッグ、ブレークポイント、ウォッチ等を調べましょう!

此れにより、コードの修正が出来ます
まず、不具合に就いて説明して置きます

以下の部分で行っている操作に就いて

  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)
    '店舗名を配列に取得
    vntData = Range(.Cells(clngDataTop, "B"), _
          .Cells(clngSheetEnd, "B").End(xlUp)).Value

B列の65536行(シートの最終行)にセルポインタを置き
一般操作で言う、「End」キー、「↑」キーを押してデータの最終行求をめ、
B列5行からB列データの最終行の値をvntDataと言う配列に読み込んでいます
当方としては、B列に店舗名しか無いと思っていましたが、
実際には店舗名の下にも何か入力されていたのですね?
此れにより、空白のセルが「同一の店舗名がある」と認識されコードが終了していました
其処で、店舗名だけを分離するのに、店舗名の下に「合計」が有る様なので此れを利用します

以下の様に、「Function MakeStoreIndex」を修正して下さい

Private Function MakeStoreIndex(dicStore As Object, _
              lngSheetNo As Long) As Boolean

'  店舗のIndexを作成

  '店舗データの先頭行位置を定数宣言
  Const clngDataTop As Long = 5
  
  Dim i As Long
  Dim vntData As Variant
  
  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)
    '店舗名を配列に取得
    vntData = Range(.Cells(clngDataTop, "B"), _
          .Cells(clngSheetEnd, "B").End(xlUp)).Value
  End With
  '店舗Indexに就いて
  With dicStore
    '店舗名の先頭から終まで繰り返し
    For i = 1 To UBound(vntData, 1)
      '配列に「合計」が出てきたらForを抜ける ★この行追加
      If Trim(vntData(i, 1)) = "合計" Then '★この行追加
        Exit For             '★この行追加
      End If                '★この行追加
      '店舗名に「店」が付いていない場合
      If Right(vntData(i, 1), 1) <> "店" Then
        '「店」を追加
        vntData(i, 1) = vntData(i, 1) & "店"
      End If
      'Indexにi番目の店舗名が有るなら
      If .Exists(vntData(i, 1)) Then
        Beep
        MsgBox "同一の店名が有ります"
        Exit Function
      'i番目の店舗名が無いなら
      Else
        'Indexに店舗名と行位置を追加
        .Add vntData(i, 1), i + clngDataTop - 1
      End If
    Next i
  End With

  MakeStoreIndex = True
  
End Function


PS: 尚、ブレークポントに就いての仕様で、ビックリする物が有るので書いて置きます
 VBEで、ブレークポントを設定したまま、ExcelのBookを保存した場合
 次に、Bookを開いてマクロを実行すると、ブレークポントの表示が無いにも関わらず
 以前にブレークポントを設定した位置で、コードがブレーク(中断)します
 この場合、一旦実行をリセットして、中断した行にブレークポントを設定します
 次に、このブレークポントを解除(●をクリックするか、「デバッグ」→
 「すべてのブレークポントの解除」)し、「デバッグ」→「VBAProjectのコンパイル」
 を行い、Bookを保存すると回避できます

 後、04/5/15(土) 1:31の質問の中でコードが以下の様におかしく成っていますが
 気を付けて下さい

        'Indexに店舗名と行位置を追加
        .Add vntData(i, 1), i + clngDataTop &#8211; 1 ・・・6.

 またこのデータは、思わぬ所にスペースだの、何だの、まだ何か有りそうな気がしますので
 何か有れば諦めずに、聞いて下さい

【13889】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/15(土) 19:20 -

引用なし
パスワード
   ▼Hirofumi さん,こんにちは。心強いお言葉ありがとうございます。
 さて、早速確認しましたが、「同一の店名があります」のメッセージはでなくなり、やっと、最終的な「処理が完了しました」とのメッセージが出るようになりました。しかし、幾つか問題が発生しました。またもやご教授願います。

1.まず、「集計表」にある先頭(6行目)の店舗のデータが貼り付けられません。ちなみに、この店舗名は「a店」です。しかし、このセルが「b(〜店がついていません)」であれば、データが貼り付けられます。

2.日にちシートへ貼り付けることができたデータについてですが、書式まで一緒に張り付いてしまいます。数値だけ貼り付け、更に桁区切りで表示し、そして、加算して貼り付けできるものでしょうか?数値だけ貼り付ける場合、以下のコードを入力しても、エラーが出てしまいます。

PasteSpecial OPERATION:=xlPasteSpecialOperationAdd, _
            Paste:=xlValue

【13895】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/15(土) 20:56 -

引用なし
パスワード
   意味が善く解らないのですが?

1、に就いて

>1.まず、「集計表」にある先頭(6行目)の店舗のデータが貼り付けられません。
>ちなみに、この店舗名は「a店」です。 

これは、「a店」が、店舗名のIndexに有る「a店」と違う場合が考えられます
其の意味は、「a店」が「a店 」で有ったり「 a店」で有ったりすると起こります
ただ、次の場合が理解できません

>しかし、このセルが「b(〜店がついていません)」であれば、データが貼り付けられます。

何故なら、「集計表」のA列の値で「店」が付かない物は全て無視されるはずです
理由は、店舗名のIndexを作るとき、店舗名には全て「店」を付けている為です
もし、データが張りつけられるとしたら其の場所は、
「a店」の行位置ですか?、「b店」の行位置ですか?

2、に就いて

これは、現状のコードは、「集計表」からCopyして来ている為、当然書式も張りつきます
値だけを張り付けたいなら簡単に修正できますが?

>更に桁区切りで表示し、そして、加算して貼り付けできるものでしょうか?

此れがどう言う意味なのか具体例を標してください
特に、加算して張りつけとは、何と何を加算するのでしょうか?

尚、当方には、当然の話として本物のデータが有りませんので
前回と同様に、ブレークポイントを設定して、ウォッチで確認して欲しいのですが?
ブレークポイントの位置は、「Sub Classification2」の

    'データの有る先頭行〜最終行まで繰り返し
    For i = clngDataTop To lngDataEnd

のForの行(コメント行は、設定できない)
ウォッチする物は、vntData(1, 1)とvntData(1, 2)です
i行のvntData(1, 1)は、A列、vntData(1, 2)はB列です
先ず、1が解決できなければ2を解決しても無駄でしょ
今夜、明日の夕方なでは、ある程度、見ていられますが、
それ以降は、夜に1回、回答出きるか同かに成ります

【13900】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/15(土) 23:29 -

引用なし
パスワード
   ▼Hirofumi さん、こんばんは。すみませんでした、説明がたりませんでした。
改めて説明させていただきます。

>意味が善く解らないのですが?
>
>1、に就いて
>
>>1.まず、「集計表」にある先頭(6行目)の店舗のデータが貼り付けられません。
>>ちなみに、この店舗名は「a店」です。 
>
>これは、「a店」が、店舗名のIndexに有る「a店」と違う場合が考えられます
>其の意味は、「a店」が「a店 」で有ったり「 a店」で有ったりすると起こります

 ★1.これは、ウォッチで確認したところ、以下の1.2.の値が「a店」だけは    「a店  」でした。その他の店は全て「b店」など、空白がありませんでし 
 た。
 よって、日付シートへ貼り付けられるデータは、a店以外の全てのデータだけで す。なぜ、a店だけが「a店  」となるのか分かりません。 


 'i行B列のセル値が日付と認識されないなら
      Else
        'コピーフラグがTrueなら
        If blnCopy Then
          '店舗Indexにi行A列の値が有るなら
          If dicStore.Exists(1.vntData(1, 1)) Then 
            '店舗の行位置を取得
            lngStoreNo _
              = CLng(dicStore.Item(2.vntData(1, 1)))


>ただ、次の場合が理解できません
>
>>しかし、このセルが「b(〜店がついていません)」であれば、データが貼り付けられます。
>
>何故なら、「集計表」のA列の値で「店」が付かない物は全て無視されるはずです
>理由は、店舗名のIndexを作るとき、店舗名には全て「店」を付けている為です
>もし、データが張りつけられるとしたら其の場所は、
>「a店」の行位置ですか?、「b店」の行位置ですか?

 ★すみません。これは、間違いです。★1.でご説明したとおりで、a店以外の店 のデータは、日付シートへ貼り付けられます。


>2、に就いて
>
>これは、現状のコードは、「集計表」からCopyして来ている為、当然書式も張りつきます
>値だけを張り付けたいなら簡単に修正できますが?

 ★これは是非とも教えてください。
 

>>更に桁区切りで表示し、そして、加算して貼り付けできるものでしょうか?
>
>此れがどう言う意味なのか具体例を標してください
>特に、加算して張りつけとは、何と何を加算するのでしょうか?

 ★桁区切りとは、集計表の数値は「2000」と位を区切るコンマがなく
 日付シートへ貼り付ける際に、「2,000」とコンマをつけたかったのですが、
 これは、「集計表」でコンマをつければ簡単なので、桁区切りの質問について  は、撤回させてください。
 ★加算貼り付けとは、日付シートには、既にセルに入力されてあるデータがあ 
 り、そこに集計表からのデータを貼り付けてしまうと、上書きされて、前の数値 が消えてしまいますので、加算して貼り付けたいと思っています。
 

★★なお、これは、会社のシステムの改変の関係で急に変わったのですが、
  日付シートの店名リストについて、以前、「〜店」が着いていると説明しまし  たが、「〜支店」のものも追加になりました。店舗数は変わりません。
  a店が「a店」のままで、それ以外の店舗が「〜支店」と変わりました。
  それと、日付シートB5〜B37にある店舗名も、a店は「a店」で、それ以外の  店舗は、「〜支店」が省かれ、「b」や「t」などの表記になっています。
  ご参考までに報告します。

【13901】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/16(日) 0:23 -

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

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=13900;id=excel
で質問した内容のうち、以下のものについては、解決しました。
【13618】の内容から、前後スペースを取るため、コードを追加しました。
追加したコードはその下に記述したとおりでよろしいのでしょうか?試したら、「a店」のデータが貼り付けることができました。

>
>>意味が善く解らないのですが?
>>
>>1、に就いて
>>
>>>1.まず、「集計表」にある先頭(6行目)の店舗のデータが貼り付けられません。
>>>ちなみに、この店舗名は「a店」です。 
>>
>>これは、「a店」が、店舗名のIndexに有る「a店」と違う場合が考えられます
>>其の意味は、「a店」が「a店 」で有ったり「 a店」で有ったりすると起こります
>
> ★1.これは、ウォッチで確認したところ、以下の1.2.の値が「a店」だけは    「a店  」でした。その他の店は全て「b店」など、空白がありませんでし 
> た。
> よって、日付シートへ貼り付けられるデータは、a店以外の全てのデータだけで す。なぜ、a店だけが「a店  」となるのか分かりません。 
>
>
> 'i行B列のセル値が日付と認識されないなら
>      Else
>        'コピーフラグがTrueなら
>        If blnCopy Then
>          '店舗Indexにi行A列の値が有るなら
>          If dicStore.Exists(1.vntData(1, 1)) Then 
>            '店舗の行位置を取得
>            lngStoreNo _
>              = CLng(dicStore.Item(2.vntData(1, 1)))
>


Public Sub Classification2()
      ・
      ・
      ・
'i行B列のセル値が日付と認識されないなら
      Else
        'コピーフラグがTrueなら
        If blnCopy Then
          vntData(1, 1) = Trim(vntData(1, 1)) ←ここを追加
          '店舗Indexにi行A列の値が有るなら
          If dicStore.Exists(vntData(1, 1)) Then


Private Function MakeStoreIndex(dicStore As Object, _
              lngSheetNo As Long) As Boolea
      ・
      ・
      ・
'店舗Indexに就いて
  With dicStore
    '店舗名の先頭から終まで繰り返し
    For i = 1 To UBound(vntData, 1)
      vntData(i, 1) = Trim(vntData(i, 1)) ←ここを追加
      '配列に「合計」が出てきたらForを抜ける ★この行追加
      If Trim(vntData(i, 1)) = "合計" Then '★この行追加
        Exit For             '★この行追加
      End If                '★この行追加

【13903】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/16(日) 1:45 -

引用なし
パスワード
   「 a店」に対する、対策ならそれでOkです

その他の物に対応する様にした場合は、以下の様に成ります
2つのプロシージャが大きく変わり、1つのプロシージャが追加に成ります
尚、転記先のセルの書式設定はコメントアウトして有りますので必要なら活かして下さい
ただし、セルの書式設定を活かすと遅く成る可能性が有ります
また、「支店」にも対応した積もりです

'★このプロシージャ変更
Public Sub Classification2()

  'Sheet1のデータ先頭行を定数として宣言
  Const clngDataTop As Long = 3

  Dim i As Long
  Dim lngDataEnd As Long
  Dim dicSheets As Object
  Dim dicStore As Object
  Dim vntData As Variant
  Dim lngSheetNo As Long
  Dim lngStoreNo As Long
  Dim blnCopy As Boolean
  Dim j As Long       '★追加
  Dim vntResult As Variant  '★追加
  Dim wksData As Worksheet  '★追加
  Dim wksResult As Worksheet '★追加
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'シートのIndexをDictionaryとして取得
  Set dicSheets _
      = CreateObject("Scripting.Dictionary")
  '店のIndexをDictionaryとして取得
  Set dicStore _
      = CreateObject("Scripting.Dictionary")
  
  'シートのIndexを作成
  If Not MakeSheetsIndex(dicSheets, lngSheetNo) Then
    GoTo ExitHandler
  End If
  
  '店のIndexを作成
  If Not MakeStoreIndex(dicStore, lngSheetNo) Then
    GoTo ExitHandler
  End If
  
  '「集計表」シートの参照を格納
  Set wksData = Worksheets("Sheet1")
  
  'データの有るシートに就いて
  With wksData
    'データの最終行を取得
    lngDataEnd = .Cells(clngSheetEnd, "A").End(xlUp).Row
  End With
  'データの有る先頭行〜最終行まで繰り返し
  For i = clngDataTop To lngDataEnd
    '配列にi行のA、B、C、D、E列を取得
    vntData = wksData.Cells(i, "A").Resize(, 5).Value '★修正
    'もし、i行B列のセル値が日付と認識されるなら
    If DateCheck(vntData(1, 2)) Then
      With dicSheets
        'もし、シートのIndexにこの日付が有るなら
        If .Exists(vntData(1, 2)) Then
          'シートの番号を取得
          lngSheetNo = CLng(.Item(vntData(1, 2)))
          '転記先の参照を格納
          Set wksResult = Worksheets(lngSheetNo)
          'コピーフラグをTrueに
          blnCopy = True
        '日付が無いなら
        Else
          '当月分と認めず、このグループを無視
          MsgBox vntData(1, 2) & "、他の月の分です。"
          'コピーフラグをFalseに
          blnCopy = False
        End If
      End With
    'i行B列のセル値が日付と認識されないなら
    Else
      'コピーフラグがTrueなら
      If blnCopy Then
        '店舗名から「店」、「支店」、Spaceを削除
        vntData(1, 1) = NameControl(vntData(1, 1)) '★追加
        '店舗Indexにi行A列の値が有るなら
        If dicStore.Exists(vntData(1, 1)) Then
          '店舗の行位置を取得
          lngStoreNo _
            = CLng(dicStore.Item(vntData(1, 1)))
          With wksResult.Cells(lngStoreNo, "Q").Resize(, 2)
            '転記先の店舗の行位置Q、R列の値を取得
            vntResult = .Value         '★追加
            '転記先Q、R列の値にデータを加算
            For j = 1 To 2           '★追加
              vntResult(1, j) _
                = vntResult(1, j) _
                    + vntData(1, 3 + j) '★追加
            Next j               '★追加
            '転記先Q、R列の位置に代入
            .Value = vntResult         '★追加
            'セルの書式設定
'            .NumberFormatLocal = "#,##0_ "   '★追加
          End With
        End If
      End If
    End If
  Next i
  
  Beep
  MsgBox "処理が完了しました"
  
ExitHandler:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  'Dictionaryを破棄
  Set dicSheets = Nothing
  Set dicStore = Nothing
  
  Set wksData = Nothing  '★追加
  Set wksResult = Nothing '★追加
  
End Sub

'★このプロシージャ変更
Private Function MakeStoreIndex(dicStore As Object, _
              lngSheetNo As Long) As Boolean

'  店舗のIndexを作成

  '店舗データの先頭行位置を定数宣言
  Const clngDataTop As Long = 5
  
  Dim i As Long
  Dim vntData As Variant
  
  '最初にIndexに追加されたシート番号に就いて
  With Worksheets(lngSheetNo)
    '店舗名を配列に取得
    vntData = Range(.Cells(clngDataTop, "B"), _
          .Cells(clngSheetEnd, "B").End(xlUp)).Value
  End With
  '店舗Indexに就いて
  With dicStore
    '店舗名の先頭から終まで繰り返し
    For i = 1 To UBound(vntData, 1)
      '配列に「合計」が出てきたらForを抜ける
      If Trim(vntData(i, 1)) = "合計" Then
        Exit For
      End If
      '店舗名から「店」、「支店」、Spaceを削除
      vntData(i, 1) = NameControl(vntData(i, 1))
      'Indexにi番目の店舗名が有るなら
      If .Exists(vntData(i, 1)) Then
        Beep
        MsgBox "同一の店名が有ります"
        Exit Function
      'i番目の店舗名が無いなら
      Else
        'Indexに店舗名と行位置を追加
        .Add vntData(i, 1), i + clngDataTop - 1
      End If
    Next i
  End With

  MakeStoreIndex = True
  
End Function

'★このプロシージャ新規追加
Private Function NameControl(ByVal vntValue As Variant) As Variant

  Const cstrExtension1 As String = "支店"
  Const cstrExtension2 As String = "店"
  
  'Spaceを削除
  vntValue = Trim(vntValue)
  '右2文字が「支店」の場合
  If Right(vntValue, 2) = cstrExtension1 Then
    '「支店」を削除
    NameControl = Left(vntValue, Len(vntValue) - 2)
  Else
    '右1文字が「店」の場合
    If Right(vntValue, 1) = cstrExtension2 Then
      '「店」を削除
      NameControl = Left(vntValue, Len(vntValue) - 1)
    Else
      NameControl = vntValue
    End If
  End If
  
End Function

【13909】Re:検索したデータを特定のシートへ貼り...
質問  ハルコ  - 04/5/16(日) 19:07 -

引用なし
パスワード
   ▼Hirofumi さん、ありがとうございます。回答内容のとおり変更し、試行してみたら、うまくいきました。更に、集計表シートへ5月1日〜31日分ということで、各日にちのデータに全支店分のデータを仮入力したものを試行してみましたところ、問題なく処理されました。長い道のりでしたが、本当にありがとうございました。
それで、私もHirohumiさんのコードを元に、更に勉強していこうと思っているのですが、どうしても分からない内容があります。最後に、以下のものだけ、ご教授いただければと思います。私の場合、「インデックス」のところが良く理解できていないと思うので、以下の質問も、それが解決しないと理解できないのかなっと思います。流れだけは、つかめるのですが、分からないコードが多すぎて、一つ一つ勉強して理解できるようにします。ので、宜しくお願いいたします。

1.Private Function MakeSheetsIndeの以下の内容についてですが、全てのシートのなかで、除外したシートがある場合は、Forループを終了するというところまでは、分かるのですが、「除外フラグ」というのが、いまいち理解できません。

 For i = 1 To .Count
      '除外フラグをFalseに
      blnExclude = False '★この行追加
      '除外するシート名の先頭〜最終まで繰り返し
      For j = 0 To UBound(vntExclude) '★この行追加
        'もしi番目のシート名が除外するシート名と一致するなら
        If .Item(i).Name = vntExclude(j) Then '★この行追加
          ''除外フラグをTrueの
          blnExclude = True '★この行追加
          'Forを抜ける
          Exit For '★この行追加
        End If '★この行追加
      Next j '★この行追加

また、シートのindexに、シートiのセルE1と同一の日付がある場合、メッセージが出るような内容だと思いますが、これは例えば、どういう場合に、このようなメッセージが出るのか分からないので、申し訳ありませんが、またご教授願います。

      'シートのIndexにこの日付が有る場合
          If dicSheets.Exists(vntDate) Then
            Beep
            MsgBox "同一の日付が有ります"
            Exit Function


2.これは、Functionプロシージャでシートインデックスが作られなかったら、と言いますか、シートインデックスがない場合は、ExitHandler:へ飛び、マクロを終了する、いう理解でよろしいのでしょうか?

 'シートのIndexを作成
  If Not MakeSheetsIndex(dicSheets, lngSheetNo) Then
    GoTo ExitHandler
  End If


  

【13910】Re:検索したデータを特定のシートへ貼り...
回答  Hirofumi E-MAIL  - 04/5/16(日) 21:07 -

引用なし
パスワード
   >  ▼Hirofumi さん、ありがとうございます。回答内容のとおり変更し、試行してみたら、うまくいきました。
>更に、集計表シートへ5月1日〜31日分ということで、各日にちのデータに全支店分のデータを仮入力したものを
>試行してみましたところ、問題なく処理されました。長い道のりでしたが、本当にありがとうございました。

善かったですね、私もどうなるかと思いました
基本的に私のコードは、難しい事は行って無い積もりです
ただ、私の癖で、WorkSheetFunction等のExcelが本来持っている機能を余り使わないので
そこら辺を上手く使うともっと簡単で早いコードに成る様な気がします

>1.Private Function MakeSheetsIndeの以下の内容についてですが、
>全てのシートのなかで、除外したシートがある場合は、
>Forループを終了するというところまでは、分かるのですが、
>「除外フラグ」というのが、いまいち理解できません。

>    For i = 1 To .Count
>      '除外フラグをFalseに
>      blnExclude = False
>      '除外するシート名の先頭〜最終まで繰り返し
>      For j = 0 To UBound(vntExclude)
>        'もしi番目のシート名が除外するシート名と一致するなら
>        If .Item(i).Name = vntExclude(j) Then
>          '除外フラグをTrueに
>          blnExclude = True
>          'Forを抜ける
>          Exit For
>        End If
>      Next j

今回の場合は、vntExcludeと言う配列の中に目的のシート(この場合、除外するシート名)が
有るか、無いかが解れば善いのでBooleanのフラグを立てています
詰まり、フラグが立っている時(フラグがTrue)は、目的のシートが有る場合
フラグが立っていない時は、目的のシートが無い場合
目的のシートとは、今処理を行おうとしているシートで、フラグがTrueなら処理し無いし、Falseなら処理
を行います
詰まり、「Next j」の後にIf分が有り、ここで「blnExclude = False」の時だけ処理を行っています
「If Not blnExclude Then 」と書いていますが「If blnExclude = False Then 」と同じ事です

>また、シートのindexに、シートiのセルE1と同一の日付がある場合、
>メッセージが出るような内容だと思いますが、これは例えば、どういう場合に、
>このようなメッセージが出るのか分からないので、申し訳ありませんが、またご教授願います。

>          'シートのIndexにこの日付が有る場合
>          If dicSheets.Exists(vntDate) Then
>            Beep
>            MsgBox "同一の日付が有ります"
>            Exit Function

これは、転記先のシートに万が一同じ日付が有った場合、其の後の処理で、エラーを起こさない様に
コードを正常終了させています
詰まり、エラーで止まるならまだ解るのですが、此れにより必要なデータを上書きして何か月も気が就かない
と言うような事を防いでいます

>2.これは、Functionプロシージャでシートインデックスが作られなかったら、と言いますか、
>シートインデックスがない場合は、ExitHandler:へ飛び、マクロを終了する、
>いう理解でよろしいのでしょうか?

>  'シートのIndexを作成
>  If Not MakeSheetsIndex(dicSheets, lngSheetNo) Then
>    GoTo ExitHandler
>  End If

理解はそれで善いと思います
私は前はこう言う場合、「Exit Sub」で書いて居たのですが、
正常にコードが終了した時も、何か異常若しくは、キャンセルされた時も
同じ終了処理を行わなければ成らない場合、
「Exit Sub」では同じ処理を幾つも書かなければ成りません
其処で、コードの出口を1つにして全て同じ終了処理を行わせています

以上

ここからは、文章が下手なので申し訳有りませんが、私が感じた事を書いて置きます
1、プログラムを作る時、先ず行う事は元と成るデータの場所、形態、性質を何かに
 詳しく書き出し、善く吟味して下さい
 例えば、シート名は何、何行何列目に有るのか、データの型は何(日付、数値、文字列?)
 文字列なら前後にSpeceが有るの、無いの等
2、結果は、何処にどう出力するのか
 これも、シートに出力なら、そのシートのレイアウトはどうなっているか?
 データの型は?等等
 此れも、詳しく書き出し、善く吟味して下さい
3、プログラムを作ると言う事は、何か加工を行う事なので其の時の条件は?
 何処に有るの?、データの型は?等等
 此れも、詳しく書き出し、善く吟味して下さい
 この3つが、きちんと決まらないとコードは書けません
 また、書かないと自分の頭が整理されないと思います
4、次に上の3つを見て、これを行う手段を考え書き出します
 先ず、大まかな物で、次に其の手段をとるには、何をしなければ成らないのかを
 書き出します
5、此れを細かく細かくしていけば、最後のコードに直すだけに成ります
次に、デバグの方法を身に付けて下さい
これは、コードをいっぱい書いて、いっぱいエラーを出して、いっぱい考えないと
身に付きません
次に、試しを厭はない様にして下さい、大きなコードを書いて最後に試すのではなく
其の都度、簡単なモデルを考え試して行き、此れを積み上げて行きます
ソウしないと上手くなりませんよ

【13911】Re:検索したデータを特定のシートへ貼り...
お礼  ハルコ  - 04/5/16(日) 22:48 -

引用なし
パスワード
   ▼Hirofumi さん、こんばんは。
 今まで、詳しくご指導していただきまして、本当にありがとうございました。
 前回の助言も踏まえ、今後とも、根強く、そして、しぶとく精進します。
 大変勉強になりました。ありがとうございました。

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