Excel VBA質問箱 IV

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

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


67695 / 76738 ←次へ | 前へ→

【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

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

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