Excel VBA質問箱 IV

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

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


11917 / 13645 ツリー ←次へ | 前へ→

【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 お礼[未読]

【13278】別シートからの転記
質問  NAO  - 04/4/30(金) 0:23 -

引用なし
パスワード
   はじめまして、NAOです。VBA初心者ですがよろしくお願いします。
次のような作業をVBAで行いたいのですが、どのようにすれば良いか分からず困っております。

型式1と型式2の2枚のシートがあり、各シートの1行目は見出しです。
両シート共、
 A列:文字列(同じ名前はありません。)
 B列:数値
 C列:数値
 D列:文字列(昇順の並んでいます。)同じ名前が複数あります。


(型式1シート)           
  A   B    C    D       
1 品名  数値1 数値2  分類    
2 車   21   18     紙   
3 電車  37   25     紙    
4 いす  11   8     木    
5 くつ  9   3     プラ     
6  :   :    :      プラ    
7  :   :    :      :     
8  :   :    :      :    
9  :   :    :      :      
:  :   :    :      :    

(型式2シート)
  A   B    C    D
1 品名  数値1 数値2  分類
2 船   43   33     石              
3 携帯  96   41     紙
4 本箱  78   8     木
5  :    :    :      木
6  :    :    :      布
:

これとは別に、分類シートが有ります。
8行目は見出し行です。

A列:9行目から15行毎に、分類の名前が記入されている。(重複は無し)
B列、F列:空白行として何も記入しない。
C列からE列には型式1シートのデータを転記する。
G列からI列には型式2シートのデータを転記する。

 
(分類シート)
          型式1             型式2           
   A  B  C   D   E     F     G   H   I  
8 分類    品名 数値1 数値2       品名 数値1 数値2
9 プラ
: 
24  鉄
:
39  紙
:


まず、(型式1シート)のD2と同じ名前を、分類シートのA列に求め、一致するものがあれば、(型式1シート)のA2:C2の内容を分類シートの一致した行のC列:E列に転記します。
これを順次繰り返しますが、先に一致したものと同じものが分類シートのA列にあれば、先に転記した行の次の行に転記を行います。

(型式1シート)の作業が終われば、(型式2シート)についても同じように転記したいのです。

どうすれば良いのかまったく分からず困っております。
よろしくお願いします。

【13279】Re:別シートからの転記
発言  かみちゃん  - 04/4/30(金) 6:51 -

引用なし
パスワード
   こんにちは。かみちゃん です。

> D列:文字列(昇順の並んでいます。)同じ名前が複数あります。
>A列:9行目から15行毎に、分類の名前が記入されている。(重複は無し)

なさりたいことは、おおむね理解できました。
形式1、形式2のシートのD列に同じ名前のものが15回を超えたら、分類シートに出力する行がなくなると思うのですが、ここはどうしたいのでしょうか?

【13281】Re:別シートからの転記
質問  NAO  - 04/4/30(金) 9:17 -

引用なし
パスワード
   ▼かみちゃん さん:
おはようございます。

>形式1、形式2のシートのD列に同じ名前のものが15回を超えたら、分類シートに出力する行がなくなると思うのですが、ここはどうしたいのでしょうか?

15回を超えるデータはありません。(最大14個までなんですが、きりの良い15となっています)

よろしくお願いします。

【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

【13300】Re:別シートからの転記
発言  Hirofumi E-MAIL  - 04/5/1(土) 10:07 -

引用なし
パスワード
   バグが有ってチョット修正して下さい
「Private Sub ListingData」の中で、以下の様に成っていますが

        'dicIndexに分類名と書き込み位置を追加
        dicIndex.Add vntComp, lngRow

此れを

        'dicIndexに分類名と書き込み位置を追加
        dicIndex.Add vntComp, lngRow + 1

の様に修正して下さい

【13318】Re:別シートからの転記
質問  NAO  - 04/5/1(土) 15:51 -

引用なし
パスワード
   ▼Hirofumi さん:レスありがとうございます。

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

初心者なもので、Dictionaryオブジェクトが使える環境になっているのかどうかも分かりません。

とりあえず、コードを標準モジュールに貼り付け、実行してみましたが、
実行時エラーが表示されただめでした。デバッグキーを押すと、
 
>  'データの有るシート数繰り返し
>  For i = 0 To UBound(vntSheets)
>    'データの出力

 より下の、

>    ListingData Worksheets(vntSheets(i)), _
>          vntWritePos(i), vntClass, _
>          lngRowPitch, dicIndex, wksResult
  
 の部分が黄色になります。

ListingDataをF1キーで見ますと、「無効なオブジェクトライブラリーです。または定義されいないオブジェクトへの参照を含んでいます。」と表示されました。

Dictionaryオブジェクトについて分からないまま、Windoows Scriptをインストールしてみましたが、だめでした。

よろしくお願いします。

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

引用なし
パスワード
   OSとExcelのバージョンは、何ですか?
Dictionaryオブジェクトは、WHS(Windows Script Host)に含まれる物で
Win98以降なら使えると思いましたが?

ただ、Dictionaryオブジェクトが無くても、少し遅く成りますが
作る事は出来ます
其の場合は以下の様に成ります

以下を標準モジュールに記述して下さい
ただし、Excelは最低限97を使用してください
Excel95は、多分駄目でしょう

Option Explicit

Public Sub Classification2()

  '分類名の間隔のピッチ
  Const lngRowPitch As Long = 15
  
  Dim i As Long
  Dim lngRow As Long
  Dim vntSheets As Variant
  Dim vntClass As Variant
  Dim wksResult As Worksheet
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '分類シートの参照を設定
  Set wksResult = Worksheets("分類シート")
  '分類シートの分類項目の初期位置を配列に取得
  With wksResult.Cells(8, "A")
    '初期位置の配列を初期化
    ReDim vntClass(1, 0)
    vntClass(1, 0) = .Row + 1 - lngRowPitch
    '配列の添え字の初期値
    i = 1
    '分類の初期位置の初期値
    lngRow = (i - 1) * 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 - 1) * lngRowPitch + 1
    Loop
  End With
  'データの有るシート名を配列に設定
  vntSheets = Array("型式1シート", "型式2シート")
  
  'データの有るシート数繰り返し
  For i = 0 To UBound(vntSheets)
    'データの出力
    ListingData Worksheets(vntSheets(i)), _
          Chr(&H43 + i * 4), vntClass, _
          lngRowPitch, wksResult
  Next i
  
  '分類シートの参照を破棄
  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, _
            wksResult As Worksheet)

  Dim i As Long
  Dim lngEnd As Long
  Dim vntComp As Variant
  Dim lngRow As Long
  Dim vntScope As Variant
  Dim lngPos As Long
  
  '出力位置を初期位置とする
  vntScope = vntClass
  
  'データの出力
  With wksData
    'データの最終行を取得
    lngEnd = .Cells(65536, "A").End(xlUp).Row
    '列見だしの下から最終行まで繰り返し
    For i = 2 To lngEnd
      '比較値を変数に取得
      vntComp = .Cells(i, "D").Value
      '出力位置の添え字を取得
      lngPos = RowSearch(vntComp, vntScope)
      'もし、比較値が有るなら
      If lngPos <> -1 Then
        '出力位置を取得
        lngRow = vntScope(1, lngPos)
        '出力位置を更新
        vntScope(1, lngPos) = lngRow + 1
      'もし、比較値が無いなら(分類項目が無い場合)
      Else
        '出力位置を最終分類項目のピッチ分下に設定
        lngRow = vntScope(1, UBound(vntScope, 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
        ReDim Preserve vntScope(1, UBound(vntScope, 2) + 1)
        vntScope(0, UBound(vntScope, 2)) = vntComp
        vntScope(1, UBound(vntScope, 2)) = lngRow + 1
      End If
      '分類の位置にデータを出力
      .Cells(i, "A").Resize(, 3).Copy _
          Destination:=wksResult.Cells(lngRow, vntCol)
    Next i
  End With
    
End Sub

Private Function RowSearch(vntKey As Variant, _
              vntScope As Variant) As Long

  Dim i As Long
  
  RowSearch = -1
  If VarType(vntScope) = vbArray + vbVariant Then
    For i = 1 To UBound(vntScope, 2)
      If vntKey = vntScope(0, i) Then
        RowSearch = i
        Exit For
      End If
    Next i
  End If
  
End Function

【13323】Re:別シートからの転記
回答  かみちゃん  - 04/5/1(土) 18:19 -

引用なし
パスワード
   こんにちは。かみちゃん です。

すでにHirofumiさんからも、コードが提示されていますが、

> ListingDataをF1キーで見ますと、「無効なオブジェクトライブラリーです。または定義されいないオブジェクトへの参照を含んでいます。」と表示されました。

と同じ状況になりました。(WindowsXP HomeEdition + Excel2002)
そこで、私もコードを作ってみました。
汚くて遅いかも?しれませんが、単純な処理で、動作確認はとれています。
ご参考になれば・・・

※転記に失敗したときには、当該セルの隣に「転記失敗」と表示します。
 また、処理前に分類シートは値クリアしています。

Option Explicit

'分類シート名格納の変数宣言
Dim Bunrui_SheetName As String

Sub TEST()
 Dim rtn As Variant
 
 Bunrui_SheetName = "分類シート"
 '分類シートの内容クリア(追加処理する場合はこの1行は不要)
 Sheets(Bunrui_SheetName).Range("C9:IV65536").ClearContents
  
 '形式1シートの転記処理(C列より転記)
 rtn = CopyValue("形式1シート", 3)
 '形式2シートの転記処理(F列より転記)
 rtn = CopyValue("形式2シート", 7)
End Sub

'シート転記処理(共通)
Function CopyValue(TargetSheet As String, ColumnNo As Integer)
 '転記元シートのA列の最終行
 Dim LastRow1 As Long
 '転記先シートへのキー
 Dim Key As String
 '添え字
 Dim i, RowNo As Long
 Dim c As Range
 
 Worksheets(TargetSheet).Activate
 '転記元シートのA列の最終行の取得(途中の行に空白行がないこと)
 LastRow1 = Range("A1").CurrentRegion.Rows.Count
 '転記処理
 For i = 2 To LastRow1
  '転記先のセル位置へのキー取得
  Key = Cells(i, 4).Value
  '「転記失敗」表示セルの消去
  Cells(i, 5).ClearContents
  '転記先のセル位置(A列)の検索
  With Worksheets(Bunrui_SheetName)
    Set c = .Range("A1:A65536").Find(Key, LookIn:=xlValues)
    If Not c Is Nothing Then
      '転記先のセル位置(行方向)の検索
      For RowNo = c.Row To c.Row + 15 - 1
       If .Cells(RowNo, ColumnNo) = "" Then Exit For
      Next
      '転記処理(転記先の列位置は、ColumnNoを参照)
      Range(Cells(i, 1), Cells(i, 3)).Copy
      Sheets(Bunrui_SheetName).Select
      Cells(RowNo, ColumnNo).Select
      ActiveSheet.Paste
      '転記元シートのコピーモードを解除
      Sheets(TargetSheet).Select
      Application.CutCopyMode = False
    Else
     '転記に失敗した場合は、当該データの右隣のセルに記述
     Cells(i, 5) = "転記失敗"
    End If
  End With
 Next
End Function

【13329】Re:別シートからの転記
お礼  NAO  - 04/5/1(土) 19:57 -

引用なし
パスワード
   ▼Hirofumi さん:ありがとうございました。今回のコードで完全にうまく処理できました。

>OSとExcelのバージョンは、何ですか?

一番最初に、書いておくべきものを忘れていました。(WindowsXpHE、Excel2000)

>Dictionaryオブジェクトは、WHS(Windows Script Host)に含まれる物で
>Win98以降なら使えると思いましたが?

Dictionaryオブジェクトについて、勉強したいと思います。

本当にありがとうございました。

【13330】Re:別シートからの転記
お礼  NAO  - 04/5/1(土) 20:06 -

引用なし
パスワード
   ▼かみちゃん さん:ありがとうございました。うまく処理できました。
VBAについて取り組みだしたばかりで、一つの処理を行うのに幾通りものコードがあることが分かりました。

Hirofumi さんのコードやかみちゃんさんのコードを、今後の勉強のため、自分なりに理解できるよう解析していきたいと思います。

【13333】Re:別シートからの転記
お礼  NAO  - 04/5/1(土) 20:37 -

引用なし
パスワード
   Hirofumiさん、動きました!

Dictionaryオブジェクトによるコードで動きました。
テスト用のファイルではなく、実際に使用する業務用のファイルに記述し試したところ完璧に処理できました。

ご迷惑をおかけし申し訳ありませんでした。

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