Excel VBA質問箱 IV

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

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


67527 / 76732 ←次へ | 前へ→

【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

5 hits

【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 お礼

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