VBA マクロ シート 転記

質問

はじめまして。VBA初心者です。今シート１のA列1行目セルにA社、A列2行目にB社、A列3行目にC社と・・ざっと1000行程あり、それぞれB列には値があります。この値をシート２のＢ列に転記したいと思っています。ただ、毎月シートを追加していきますので、左隣のシートから転記しなければなりません。シート２の項目は同じA列とB列で構成されています。A列の値が多少前後するので、FINDを使って以下のようなプログラムを作りました。ただ、左隣のシートから転記とう内容をどうやって追加したら良いのかがわかりません。Previous　をどこかに使えばできるのかなとも思うのですが、その方法がわかりません。

Sub 転記()
Dim ws As Worksheet, ws1 As Worksheet, r As Range, r1 As Range
Dim LastRow As Long, i As Long, er As Long, wkey As String
Set ws = Worksheets("Sheet1")
Set ws1 = Worksheets("Sheet2")
LastRow = ws.Range("A1").End(xlDown).Row
er = ws1.Range("A1").End(xlDown).Row
Set r = ws.Range("A1:A" & LastRow)
For i = 1 To er
wkey = ws1.Range("A" & i)
Set r1 = r.Find(What:=wkey, LookIn:=xlValues, LookAt:=xlWhole)
If Not r1 Is Nothing Then
ws1.Range("B" & i) = r1.Offset(, 1)
End If
Next
Set r1 = Nothing
Set r = Nothing
Set ws = Nothing
Set ws1 = Nothing
End Sub

どなたか詳しいお方いらっしゃいましたら、初心者の私に教えて頂けませんでしょうか？宜しくお願いします。

回答No.4

onlyrom · ベストアンサー

先ほど投稿したのですが反映されてないので再投稿します。

問題は、シート名を特定できないところにあるわけですから、
それを回避するための方法として、アクティブなシートを
基準にする方法があります。

左から、Sheet1,Sheet2,Sheet3　の順とする

転記元：Sheet1　（アクティブシートの前のシート）
転記先：Sheet2　（アクティブシート）

アクティブシート（Sheet2）の前のシート（Sheet1）から、
アクティブシート（Sheet2）に転記する場合。

ただ、このようにシート名を明示しない方法では、
シートの選択ミスが起こりますので少なくともそれを
ユーザーに確認させるようにしなければいけません。

で、それを含め質問者のコードを生かして書くと、以下のようなコードになります。

●●●●●の間のコードを追加、修正（2行）しました。

'-----------------------------------------------
Sub 転記()
Dim ws As Worksheet, ws1 As Worksheet, r As Range, r1 As Range
Dim LastRow As Long, i As Long, er As Long, wkey As String

'●●●●●
　Dim Msg

　If ActiveSheet.Index = 1 Then
　　MsgBox "転記先シートが一番左なので実行できない", vbCritical, "エラー"
　　Exit Sub
　End If

　Msg = MsgBox(Sheets(ActiveSheet.Index - 1).Name & "　から　" & _
　　　ActiveSheet.Name & "　へ転記しますか？", vbYesNo, "確認")

　If Msg = vbNo Then
　　　MsgBox "転記は中止します"
　　　Exit Sub
　　End If

'▼▼▼　修正

　Set ws1 = ActiveSheet　　　　　　　　　'Sheet２
　Set ws = Worksheets(ws1.Index - 1)　　'Sheet１

'●●●●●

LastRow = ws.Range("A1").End(xlDown).Row
er = ws1.Range("A1").End(xlDown).Row
Set r = ws.Range("A1:A" & LastRow)
For i = 1 To er
wkey = ws1.Range("A" & i)
Set r1 = r.Find(What:=wkey, LookIn:=xlValues, LookAt:=xlWhole)
If Not r1 Is Nothing Then
ws1.Range("B" & i) = r1.Offset(, 1)
End If
Next
End Sub
'----------------------------------------------

上記コードでは、前後（左右）のシートを特定するのに、シートのIndex番号を使いましたが、
質問にもあるように、Previousプロパティを使うこともできます。
以上。

お礼

非常に分かり易い説明をありがとうございました。アクティブシートを基準に考えれば良かったのですね。本当にありがとうございました。非常に勉強になりました。感謝感謝です。

回答No.3

higekuman

シートは、左から順に、Worksheets(1)、Worksheets(2)、、、、Worksheets(n)、と書くことが出来ます。

そして、ワークシートの全枚数は、Worksheets.Count、で求めることが出来ます。

一番右端のシートは、Worksheets(Worksheets.Count)、右端から2番目のシートは、Worksheets(Worksheets.Count - 1)、となります。

非表示のシートがある場合は、ご自分でいろいろと試してみてください。

回答No.2

lukulu

この辺りの参考に頑張って見て下さい！

http://officetanaka.net/excel/vba/tips/tips70.htm

http://hpcgi1.nifty.com/kenzo30/b_cbbs/cbbs.cgi?mode=al2&namber=14707&rev=1&no=0&P=R&KLOG=94

回答No.1

higekuman

初心者が書けるコードではないと思うのですが・・・(笑)

いろいろやり方はあると思いますが、私ならこうします。

Sub Macro1()

Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

Dim r1 As Range, r2 As Range
Set r2 = ws2.Cells(1, 1)

Do Until IsEmpty(r2.Value)
Set r1 = ws1.Columns(1).Find(r2.Value)
If Not r1 Is Nothing Then
r2.Offset(, 1).Value = r1.Offset(, 1).Value
End If
Set r2 = r2.Offset(1)
Loop

Set ws1 = Nothing
Set ws2 = Nothing
Set r1 = Nothing
Set r2 = Nothing

End Sub

お礼

早速のご回答ありがとうございます。色々やり方があるのですね。シートを毎月追加するのですが、シート名が毎回違います。ですので、左隣のシートから常に転記したいのですが、どうにかならないでしょうか？
説明が不十分で申し訳ありません。