Excel VBA質問箱 IV

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

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


67982 / 76734 ←次へ | 前へ→

【13299】Re:別シートからの転記
回答  Hirofumi E-MAIL  - 04/5/1(土) 9:34 -

引用なし
パスワード
   Dictionaryオブジェクトが使える環境ならこんなコードで善いかな?
以下を標準モジュールに記述してください

Option Explicit

Public Sub Classification()

  '分類名の間隔のピッチ
  Const lngRowPitch As Long = 15
  
  Dim i As Long
  Dim lngRow As Long
  Dim vntSheets As Variant
  Dim vntWritePos As Variant
  Dim vntClass() As Variant
  Dim wksResult As Worksheet
  Dim dicIndex As Object
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '分類シートの参照を設定
  Set wksResult = Worksheets("分類シート")
  '分類シートの分類項目の初期位置を配列に取得
  With wksResult.Cells(8, "A")
    '配列の添え字の初期値
    i = 0
    '分類の初期位置の初期値
    lngRow = i * lngRowPitch + 1
    '分類項目が無くなるまで繰り返し
    Do Until .Offset(lngRow).Value = ""
      '初期位置の配列を確保
      ReDim Preserve vntClass(1, i)
      '分類名を代入
      vntClass(0, i) = .Offset(lngRow).Value
      '初期位置を代入
      vntClass(1, i) = lngRow + .Row
      '添え字のカウンタを更新
      i = i + 1
      '初期位置を計算
      lngRow = i * lngRowPitch + 1
    Loop
  End With
  'データの有るシート名を配列に設定
  vntSheets = Array("型式1シート", "型式2シート")
  '分類シートに対するデータの出力位置を設定
  vntWritePos = Array("C", "G")
  
  'Dictionaryオブジェクトのインスタンスを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  'データの有るシート数繰り返し
  For i = 0 To UBound(vntSheets)
    'データの出力
    ListingData Worksheets(vntSheets(i)), _
          vntWritePos(i), vntClass, _
          lngRowPitch, dicIndex, wksResult
  Next i
  
  'Dictionaryオブジェクトのインスタンスを破棄
  Set dicIndex = Nothing
  '分類シートの参照を破棄
  Set wksResult = Nothing
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が終了しました"
  
End Sub

Private Sub ListingData(wksData As Worksheet, _
            vntCol As Variant, _
            vntClass As Variant, _
            lngPitch As Long, _
            dicIndex As Object, _
            wksResult As Worksheet)

  Dim i As Long
  Dim lngEnd As Long
  Dim vntComp As Variant
  Dim lngRow As Long
  
  'Dictionaryに初期値を設定
  With dicIndex
    For i = 0 To UBound(vntClass, 2)
      .Item(vntClass(0, i)) = vntClass(1, i)
    Next i
  End With
  
  'データの出力
  With wksData
    'データの最終行を取得
    lngEnd = .Cells(65536, "A").End(xlUp).Row
    '列見だしの下から最終行まで繰り返し
    For i = 2 To lngEnd
      '比較値を変数に取得
      vntComp = .Cells(i, "D").Value
      'もしdicIndexに比較値が有なら
      If dicIndex.Exists(vntComp) Then
        '出力位置を取得
        lngRow = dicIndex.Item(vntComp)
        '出力位置を更新
        dicIndex.Item(vntComp) = lngRow + 1
      'もしdicIndexに比較値が無いなら(分類項目が無い場合)
      Else
        '出力位置を最終分類項目のピッチ分下に設定
        lngRow = vntClass(1, UBound(vntClass, 2)) + lngPitch
        '分類項目を追加
        wksResult.Cells(lngRow, "A").Value = vntComp
        '初期位置の配列を拡張し、分類名と書き込み位置を追加
        ReDim Preserve vntClass(1, UBound(vntClass, 2) + 1)
        vntClass(0, UBound(vntClass, 2)) = vntComp
        vntClass(1, UBound(vntClass, 2)) = lngRow
        'dicIndexに分類名と書き込み位置を追加
        dicIndex.Add vntComp, lngRow
      End If
      '分類の位置にデータを出力
      .Cells(i, "A").Resize(, 3).Copy _
          Destination:=wksResult.Cells(lngRow, vntCol)
    Next i
  End With
    
End Sub
1 hits

【13278】別シートからの転記 NAO 04/4/30(金) 0:23 質問
【13279】Re:別シートからの転記 かみちゃん 04/4/30(金) 6:51 発言
【13281】Re:別シートからの転記 NAO 04/4/30(金) 9:17 質問
【13299】Re:別シートからの転記 Hirofumi 04/5/1(土) 9:34 回答
【13300】Re:別シートからの転記 Hirofumi 04/5/1(土) 10:07 発言
【13333】Re:別シートからの転記 NAO 04/5/1(土) 20:37 お礼
【13318】Re:別シートからの転記 NAO 04/5/1(土) 15:51 質問
【13320】Re:別シートからの転記 Hirofumi 04/5/1(土) 17:28 回答
【13329】Re:別シートからの転記 NAO 04/5/1(土) 19:57 お礼
【13323】Re:別シートからの転記 かみちゃん 04/5/1(土) 18:19 回答
【13330】Re:別シートからの転記 NAO 04/5/1(土) 20:06 お礼

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