Excel VBA質問箱 IV

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

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


67393 / 76738 ←次へ | 前へ→

【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

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

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