[[20190816150906]] 『条件別にシート間のデータ転記』(とり) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『条件別にシート間のデータ転記』(とり)

シート間の転記についての質問です。
データ一覧シートから、コード1〜1000のデータ行はシート1へ、コード1001からのデータ行はシート2へ転記させたいです。
現状書いたコードは以下ですが、シート1への転記は思い通りですが、シート2への転記がシート1と同じ内容の途中までとなってしまいます。
独学初心者で基本的な事が理解できていないかもしれませんがよろしくお願い致します。

・データ一覧シートはA列コード順で並んでいます
・コードは重複していたり連続していたり飛んでいたりします
・転記先のシート1、シート2も体裁は同じです

データ一覧シート
  A列  B列  C列  D列  E列
1 コード 品名  摘要  数量  日付
2 1   AAA  AAA  100  8/9
3 1   BBB  BBB  200  8/9 
4 2   AAA  CCC  300  8/10
5 10   CCC  DDD  100  8/10
6 1005 BBB  EEE   200  8/11
7 1007 AAA  FFF   300  8/11



 Sub test()

 Dim Sh1 As Worksheet
 Dim Sh2 As Worksheet
 Dim ShD As Worksheet
 Dim myRow As Long

  Set Sh1 = Worksheets("シート1")
  Set Sh2 = Worksheets("シート2")
  Set ShD = Worksheets("データ一覧")

 Dim i As Long
 Dim cmax
 cmax = Cells(Rows.Count, 1).End(xlUp).Row

 For i = 2 To cmax

  If ShD.Cells(i, "A") < 1000 Then

     With Sh1
       myRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
               .Range("A" & myRow & ":E" & myRow).Value = ShD.Range("A" & myRow & ":E" & myRow).Value
     End With
  Else
     With Sh2
       myRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
               .Range("A" & myRow & ":E" & myRow).Value = ShD.Range("A" & myRow & ":E" & myRow).Value
     End With
  End If    
 Next i
 End Sub

< 使用 Excel:Office365、使用 OS:Windows10 >


データ一覧シートのコピーする行の指定が変です。
ご自身で、考えて解決してみてください。
デバック力が身に付きますよ。
がんばってください。
(tkit) 2019/08/16(金) 16:13

tkit様
ありがとうございます!解決しました。
とりあえずエラー無く実行ができると
思考停止してしまうレベルですが勉強続けたいと思います。
ご指摘ありがとうございました。
(とり) 2019/08/16(金) 16:43

解決済みのようなので参考です。

■1
Withステートメントを使ったり記述方法を工夫すれば、変数をたくさん使わなくても大丈夫そうです。

    Sub test2()
        Dim i As Long

        With Worksheets("データ一覧")
            For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row

                With .Cells(i, "A")
                    If .Value < 1000 Then
                        Worksheets("シート1").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = .Resize(, 5).Value
                    Else
                        Worksheets("シート2").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = .Resize(, 5).Value
                    End If
                End With

            Next i
        End With

    End Sub

■2
件数にもよりますが、ループ処理で1行ずつ処理すると時間がかかりそうに思いますので、条件にあうのを"抽出"して一気に(値を)コピペするというアプローチもあるとおもいます。

    Sub ループせず抽出で対応()

        With Worksheets("データ一覧")

            '▼オートフィルタ(が設定されていたら解除)
            .AutoFilterMode = False

            '▼1000未満の処理
            .Range("A1:E1").AutoFilter Field:=1, Criteria1:="<1000"
            .AutoFilter.Range.Copy
             Worksheets("シート1").Range("A1").PasteSpecial Paste:=xlPasteValues

            '▼1000以上の処理
            .Range("A1:E1").AutoFilter Field:=1, Criteria1:=">=1000"
            .AutoFilter.Range.Copy
             Worksheets("シート2").Range("A1").PasteSpecial Paste:=xlPasteValues

            '▼オートフィルタ解除
            .AutoFilterMode = False

            Application.CutCopyMode = False

        End With
    End Sub

(もこな2) 2019/08/16(金) 19:23


もこな様
我ながらくどい記述だなとは思っておりましたので
大変参考になります。
色々と試してみたいと思います。
ご指摘ありがとうございました。
(とり) 2019/08/19(月) 10:13

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.