Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : 指定なし)
項目を合わせて転記したい。(再)
投稿日時: 19/02/11 09:55:51
投稿者: ど素人

simpleさん
フィルターオプション教えていただいたのですが、
この場合はいかがでしょうか?
 
ブックの中に「DATA」と「sheet1」と「sheet2」の3つのシートがあります。
 「DATA」A列に商品コード B列に商品名 C列に品番 D列に単価 E列に区分 と項目があります。
Sheet1には A列に商品コード B列に商品名 C列に品番 D列に単価 E列に区分
Sheet2に A列商品名 B列に商品コード C列に単価 
Sheet2には品番と区分項目がありません。 
それをSheet1とSheet2のデータを「DATA」のシートへ既に存在する一番下の行へ項目を合わせて
転記したいのですが方法を教えてください。
Sheet2にSheet3と同じように項目を追加するとできましたが、Sheet2には、いろいろなパターンの
データを張り付けて使用したいと考えています。
再度ご教授お願いいたします。
 

回答
投稿日時: 19/02/11 10:31:53
投稿者: simple

>Sheet2にSheet3と同じように項目を追加するとできましたが
それでいいんじゃないですか?
 
フィルタオプションは、
「(列の順序は問わないとしても)書込先が連続したひとつの領域になる」必要はあるでしょうね。
つまり、飛び飛びの領域への書込を一回のフィルタオプションでは書き込めないでしょう。
 
統合するのであれば、もともと、
「各シートは同じフォーマットを使用する」という方向に考えた方がよいと思いますが、
それとは逆方向を指向されるなら、
> VBAでFIND関数を使って項目を探して何行目に位置しているか検索して
> 項目を合わせる方法をイメージしてVBAをかじりかけたのですが、

その方法でもよいと思いますよ。
 
できているところまでアップしてみてはどうですか?

投稿日時: 19/02/11 17:54:30
投稿者: ど素人

simpleさんコメントありがとうございました。
項目数が何項目あるのか覚えていないですが、複数のブックにDATAがあるので、
それをSheet2へ張り付けて、その時にどの項目が欠けているかを判断するのに
ひと手間がかかるので、ボタン一つでマクロを走らせて完成できる仕組みをイメージしています。
VBA自分で組めるといいのですが・・・かなりハードルが高いですが、少し勉強してみます。
また、その時はアドバイスをお願いいたします。

回答
投稿日時: 19/02/11 20:52:47
投稿者: simple

<<Sheet2>>

    A       B          C
1   商品名  商品コード 単価
2   aaa     10         100
3   bbb     20         200
4   ccc     30         300
5   ddd     40         400
のようなデータを DATAシートの最終行以下に追記するコード例です。
 
Sub test()
    Dim wsDATA  As Worksheet
    Dim ws2     As Worksheet
    Dim rng     As Range
    Dim col     As Range
    Dim title   As String
    Dim lastRow As Long
    Dim destRow As Long
    Dim m
    
    Set wsDATA = Worksheets("DATA")
    Set ws2 = Worksheets("Sheet2")
        
    '転記元の範囲
    Set rng = ws2.Range("A1").CurrentRegion
    lastRow = rng(rng.Count).Row
    
    '書込先の行位置(A列の最終行が、データの最終行と仮定)
    destRow = wsDATA.Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    'DATAシートへの転記
    For Each col In rng.Columns
        title = ws2.Rows(1).Cells(1, col.Column)        '転記元項目の見出し
        m = Application.Match(title, wsDATA.Rows(1), 0) 'マッチするのは何列目か
        If Not IsError(m) Then
            '転記
            ws2.Range(ws2.Cells(2, col.Column), ws2.Cells(lastRow, col.Column)).Copy _
                wsDATA.Cells(destRow, m)
        Else
            MsgBox title & " という項目は DATAシートに無い"
        End If
    Next
End Sub

【補足】
> それをSheet2へ張り付けて、その時にどの項目が欠けているかを判断するのに
> ひと手間がかかるので、

それなら、尚更のこと、直接DATAシートに書き込んでしまわないほうがよいと思う。
DATAシートと同じ見出し順の作業用シートにいったん(手作業またはマクロで)書き込み、
よく確認してからのちに、DATAシートに転記をしたほうがよい。
(上のコードは直接、DATAシートに書き込んでいるから、要注意、要修正でしょう)
 
一般に、マクロで実行すると、想定外のことがあっても間違いに気づきにくいはず。
マクロだから正確とも限らない。
例えば、
・A列の最終行の項目がたまたま欠けていたとすると、
 最終行の判定が狂って、間違って上書きしてしまう、等が起こりえる。
・同じ行には、同じ要素についての情報であるべきなのに、
  間違って別の要素のものを転記してしまう、
などということは簡単に起こりえます。
一度、転記前の状態を確認して間違いが無いことを確認すべきです。

投稿日時: 19/02/11 21:15:06
投稿者: ど素人

simpleさんありがとうございました。
感激です。
先ほどから2時間ぐらいかけて途中までやってみましたが、
2回目に最終行へ張り付けるのがなかなか難しいので、行き詰まっていました。
さらに無駄なコードを書いているんだろうなと思いながらもっときれいなコードが
あるんだろうなと思っていました。
書いていただきましたコードは私がイメージしているそのものです。
本当にありがとうございました。
参考までに私なりにコードをかき集めたまだ2項目しかコピペできないですが、記載します。
でもこのコードは決定的なアラーが起きることが目に見えていました。
ありがとうございました。
 
Sub 項目名を探して情報をコピィー()
  Dim sheet1最終行 As Integer
  Dim sheet2最終行 As Integer
  Dim X1, X2 As String
  X1 = Sheets("Sheet1").Range("A1").Value
    sheet1最終行 = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    Range("A2", "A" & sheet1最終行).Select
    Selection.Copy
    sheet2最終行 = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
    Sheets("Sheet2").Select
  
   Range("A1:E1").Find(X1).Offset(sheet2最終行, 0).Select
      ActiveSheet.Paste
    Sheets("Sheet1").Select
 
   X2 = Sheets("Sheet1").Range("B1").Value
    sheet1最終行 = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    Range("B2", "B" & sheet1最終行).Select
    Selection.Copy
    sheet2最終行 = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
    Sheets("Sheet2").Select
   Range("A1:E1").Find(X2).Offset(sheet2最終行, 0).Select
    ActiveSheet.Paste
   Sheets("Sheet1").Select
 
End Sub