Excel VBA質問箱 IV

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

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


67617 / 76732 ←次へ | 前へ→

【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

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

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