マクロ修正お願いします。

質問

以前質問してマクロを作成してもらった者です。
人事データ用に作っていただきました。

Sheet1

　　A　　　B　　　C
1　処遇　コード　名前．．．．
2　退社　　3　　　あ　　
3　異動　　4　　　か　　
4　入社　　20　　　さ　

Sheet2

　　A　　　B　　　　C
1　コード　名前　　データ1．．．
2　　3　　　あ　　　
3　　4　　　か　　　
4　　

Sub testsample()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim r As Range, c As Range
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
For Each c In Sh1.Range("A2", Sh1.Range("A65536").End(xlUp))
Select Case c.Value
Case "入社"
　c.Offset(, 1).Resize(, 255).Copy Sh2.Range("A2").End(xlDown).Offset(1)
　'B列より、右端255行を、シート2のA列の最後尾の次にコピーする。
Case "異動"
　Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole)
　If Not r Is Nothing Then c.Offset(, 1).Resize(, 255).Copy r
　'コードを検索して、その見つかったものを上書き
Case "退社"
　Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole)
　If Not r Is Nothing Then r.EntireRow.Delete
　'コードを検索して、その見つかったものを削除
End Select
Next
End Sub

このマクロで一箇所どーしたらいいか分からない場所があります。
「異動」があった場合、sheet1には氏名コードと新しく配属される部署やtelなどのみを書き、メールアドや氏名など異動しても変わらないものは書き込みません。変更があった箇所のみ上書きし空白部分はそのままにしたいです。何度もすみませんがお願いします。

回答No.5

Wendy02 · ベストアンサー

papayukaさん、

＞なぜ Offset が使えないのでしょう？
＞１対１で指定するなら Offset でも Cells でも同じだと思いますが、、、

それは、Offset の利用には、カスタマイズする際には、マクロを知らない人を対象とするには、問題が出ないか、ということです。今回、ご質問者が最終的にカスタマイズしてもらうことになるのは避けられません。

私が作ったものをペタっと貼り付けて、それで問題なければよいのですが、Cells　とOffset の、直接列番号を入れていくのと、相対距離を入れていくのでは、やはり、修正には違いがあるということです。

　Cells で入れていただくのが、手っ取り早いと考えました。
　Cellsなら、マクロの教本の初歩にも載っているような内容なら、分かるはずですから、後の加工もしやすいはずです。今回、その部分は、With ステートメントを使うのもやめました。

それから、A1 を　A2に変えて　End(xlDown)で、エラーになるというのは、何もないデータシートの場合かもしれません。

Sh2.Range("A65536").End(xlUp)).Offset(1)

のほうがベターかもしれませんね。
ただ、確実なのは、上から行が詰まっていくということであって、間断なく行が詰まっているという条件は出ていません。A2のEndプロパティでエラーが出る条件は、データがないという設定としてあるはずですね。

もともと、何もないところから、私の作りあげたローカルのサンプル・データで、プロトタイプの話ですから、なるべく読みやすく書いて、後は、ご質問者にカスタマイズしかないと思っています。

回答No.4

papayuka

Wendy02さん、こんにちは。

> Offset が使えるとは限りません

なぜ Offset が使えないのでしょう？
１対１で指定するなら Offset でも Cells でも同じだと思いますが、、、

ただ、 Sh2.Cells(j, "B").Value = Sh1.Cells(i, "B").Value のように書けるのでCellsの方が判り易いですね。

余談ですが、質問通りのデータで実行すると入社でエラーになります。

　c.Offset(, 1).Resize(, 255).Copy Sh2.Range("A2").End(xlDown).Offset(1) は、
　c.Offset(, 1).Resize(, 255).Copy Sh2.Range("A1").End(xlDown).Offset(1) か、
　c.Offset(, 1).Resize(, 255).Copy Sh2.Range("A65536").End(xlUp).Offset(1) の方が良いかも。

回答No.3

Wendy02

papayukaさんへ

あくまでも、私の作ったとおりならよいのですが、本当のセル位置がわからないので、Offset が使えるとは限りません。(;_;)

ご質問の最初のシートサンプル自体も、私が書いたものです。

ご質問者自身が、各々の列に対して、Cells(行,列)の列部分の数字を入れていただくのが分かりやすいかなって判断しました。ご質問者には、Offset が、ずれていく分だけちょっと分かりにくいかなって思いました。
分かれば、そちらでやってもらってよいのですが。

回答No.2

papayuka

すべて他人まかせだとつらいですよ。

Case "異動"
　Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole)

'　　↓ここを
' If Not r Is Nothing Then c.Offset(, 1).Resize(, 255).Copy r

'　　↓こんな感じに直せば良いかな、、、
　　If Not r Is Nothing Then
　　　 c.Offset(, 3).Copy r.Offset(, 2)
　　　 c.Offset(, 4).Copy r.Offset(, 3)
　　　 '他にもあれば追加
　　End If

見つけたセルの左から3番目を転記先の左から2番目にコピー
見つけたセルの左から4番目を転記先の左から3番目にコピー

ってな意味

回答No.1

Wendy02

こんばんは。

もともと、セル位置などは分かりませんので、こちらのサンプルを出して、それを例にさせていただきますから、後は、ご自身で直してください。

以下のマクロの変更部分の説明

Sh2.Cells(j, 2).Value = Sh1.Cells(i, 2).Value　'氏名
　　　　　　　↑　　　　　　　　　　　↑
　　　　　　　列の番号(B列)　　　　列の番号(B列)

シート2 と シート1 では違う部分もあるかと思いますが、それは、それぞの列番号を入れてください。

以下は、ほんの一例です。

Sheet1

　A　　　　B　　　C　　　　D　　　　　F　
　異動　　氏名　　コード　　部署　　tel

Sub TestSample2()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim r As Range, c As Range, i As Long, j As Long
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
For Each c In Sh1.Range("A2", Sh1.Range("A65536").End(xlUp))
Select Case c.Value
Case "入社"
　c.Offset(, 1).Resize(, 255).Copy Sh2.Range("A2").End(xlDown).Offset(1)
　'B列より、右端255行を、シート2のA列の最後尾の次にコピーする。
Case "異動"
　Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole)
　If Not r Is Nothing Then
　　 i = c.Row 'Sheet1 側の該当行
　　 j = r.Row 'Sheet2 側の該当行
　 '変更部分
　 Sh2.Cells(j, 2).Value = Sh1.Cells(i, 2).Value　'氏名
　 Sh2.Cells(j, 3).Value = Sh1.Cells(i, 3).Value　'コード
　 Sh2.Cells(j, 4).Value = Sh1.Cells(i, 4).Value　'部署
　 Sh2.Cells(j, 5).Value = Sh1.Cells(i, 5).Value　'tel

　End If
　'コードを検索して、その見つかったものを上書き
Case "退社"
　Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole)
　If Not r Is Nothing Then r.EntireRow.Delete
　'コードを検索して、その見つかったものを削除
End Select
Next
End Sub