[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『条件別にシート間のデータ転記』(とり)
シート間の転記についての質問です。
データ一覧シートから、コード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 >
■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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.