Excel VBA データの転記

質問

Excel2003を使用しています。

Sheet1のB1セルとSheet2のB1セルのデータが一致したら、Sheet2のB1セル～E1セルのデータをSheet1のF1セル～Iセルに転記するというコードを書いています。

Sheet1のデータ最終行を取得して、上記の条件を満たさなかったSheet2のB1セル～E1セルのデータをSheet1のデータ最終行の1行下から順に転記するという内容を追加したいのですが、転記先の指定の仕方が悪いのか、希望通りになりません。

どなたか一例を示していただけないでしょうか？
スマホからの投稿で、実際に書いているコードを記載できず、分かりづらくて申し訳ないのですが、よろしくお願いします。

回答No.2

KURUMITO · ベストアンサー

例えば次のようなコードにします。

Sub 試験()
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
Dim n, m, i As Long
Application.ScreenUpdating = False
n = Range("B65536").End(xlUp).Row
m = 0
For i = 1 To n
If WS1.Range("B" & i).Value = WS2.Range("B" & i) Then
WS2.Range(WS2.Range("B" & i), WS2.Range("E" & i)).Copy
WS2.Paste (WS1.Range("F" & i))
ElseIf WS1.Range("B" & i).Value <> WS2.Range("B" & i) Then
WS2.Range(WS2.Range("B" & i), WS2.Range("E" & i)).Copy
m = m + 1
WS2.Paste (WS1.Range("B" & n + m))
End If
Next
Application.ScreenUpdating = True
End Sub

お礼

回答ありがとうございます。

教えていただいたコードはこちらで書いたコードと似たような感じでしたので(Copyは使わず、.Value=.Valueとしています)実際のデータに合わせて書き換えて試してみましたが、うまくいきませんでした。

詳細は先の回答者様のお礼欄にも書かせていただきましたが、もう少し調べてみようと思います。

回答No.5

keithin

それは結局、こーいうことだと思いますが。

sub macro1r1()
　dim r as long
　worksheets("Sheet1").select

　for r = 1 to application.max(range("B65536").end(xlup).row, worksheets("Sheet2").range("B65536").end(xlup).row)
　　iif(cells(r, "B").value = worksheets("Sheet2").cells(r, "B").value, cells(r, "F"), range("B65536").end(xlup).offset(1)).resize(1, 4).value = worksheets("Sheet2").cells(r, "B").resize(1, 4).value
　next r
end sub

お礼

お礼が大変遅くなり、申し訳ありません。
再度の回答ありがとうございました。

回答No.4

choco-ball

Sheet1とSheet2の行数が違う場合に
Sheet1の最終行までチェックさせるのか
Sheet2の最終行までチェックさせるのかで処理が変わります。

Sheet1に追加していくことを考えると
チェックはSheet2の最終行までやればいいのかと思いましたので
処理はSheet2の最終行までにしています。

もし、Sheet1の最終行まで処理させる場合でも

EndRowS2 = Sheets("Sheet2").Range("F65536").End(xlUp).Row

の"Sheet2"を"Sheet1"に書き換えるだけでいいはずです。

Dim S1B1 As Range 'Sheet1のB1セル
Dim S2B1 As Range 'Sheet2のB1セル
Dim TargetRG As Range '貼り付け先のセル範囲
Dim SourceRG As Range 'コピー元のセル範囲
Dim EndRowS1 As Long '最終行
Dim EndRowS2 As Long '最終行
Dim i As Long

EndRowS2 = Sheets("Sheet2").Range("F65536").End(xlUp).Row

For i = 1 To EndRowS2
Set S1B1 = Sheets("Sheet1").Range("B" & i)
Set S2B1 = Sheets("Sheet2").Range("B" & i)
Set SourceRG = Sheets("Sheet2").Range("B" & i & ":E" & i)

If S1B1.Value = S2B1.Value Then
Set TargetRG = Sheets("Sheet1").Range("F" & i & ":I" & i)
TargetRG.Value = SourceRG.Value
Else
EndRowS1 = Sheets("Sheet1").Range("F65536").End(xlUp).Row + 1
Set TargetRG = Sheets("Sheet1").Range("F" & EndRowS1 & ":I" & EndRowS1)
TargetRG.Value = SourceRG.Value
End If
Next i

お礼

お礼が大変遅くなり、申し訳ありません。
再度の回答ありがとうございました。

回答No.3

keithin

各シートのＢ１同士、続いてＢ２同士…を上から順に見ていくといった単純なお話でいいんでしょうかね。

＞転記するというコードを書いています。

いずれにしてもこれをベースにして、転記先があっちなのかこっちなのかを追加するだけです。

sub macro1()
　dim r as long
　worksheets("Sheet1").select

　for r = 1 to range("B65536").end(xlup).row
　　iif(cells(r, "B").value = worksheets("Sheet2").cells(r, "B").value, cells(r, "F"), range("B65536").end(xlup).offset(1)).resize(1, 4).value = worksheets("Sheet2").cells(r, "B").resize(1, 4).value
　next r
end sub

お礼

回答ありがとうございます。

最初、コードを作成する際、Resizeを使おうとしたのですが、うまくいかず、回答No.2様のような感じでコードを書いていましたので、教えていただいたコードは勉強になりました。

まだ、完成には至っていませんが、もう少し調べてみます。

回答No.1

choco-ball

こんなコードを書いてみましたがいかがでしょうか？

Dim S1B1 As Range 'Sheet1のB1セル
Dim S2B1 As Range 'Sheet2のB1セル
Dim TargetRG As Range '貼り付け先のセル範囲
Dim SourceRG As Range 'コピー元のセル範囲
Dim EndRow As Long　'最終行

Set S1B1 = Sheets("Sheet1").Range("B1")
Set S2B1 = Sheets("Sheet2").Range("B1")
Set SourceRG = Sheets("Sheet2").Range("B1:E1")

If S1B1.Value = S2B1.Value Then
Set TargetRG = Sheets("Sheet1").Range("F1:I1")
TargetRG.Value = SourceRG.Value
Else
EndRow = Sheets("Sheet1").Range("F65536").End(xlUp).Row + 1
Set TargetRG = Sheets("Sheet1").Range("F" & EndRow & ":I" & EndRow)
TargetRG.Value = SourceRG.Value
End If

お礼

回答ありがとうございます。

教えていただいたコードをこちらの実際のデータに合わせて試してみましたが、うまくいきませんでした。

質問内容から漏れていて申し訳なかったのですが、Sheet1とSheet2のデータはデータの行数が違うので、それぞれのシートでデータ最終行を取得して、ループさせていました。
そのためか、条件を満たさなかったSheet2のデータをSheet1最終行の1行下へ転記するときに、何度もループしている結果と思われるデータが表示Sheet1最終行から順に下へ移動させる部分に問題がありそうな気はしています。