[[20181007171923]]　『「シートA」と「シートB」を比較して抜けてるデー』（ころまる）　ページの最後に飛ぶ

『「シートA」と「シートB」を比較して抜けてるデータを「シートB」に入力』（ころまる）

初めて利用させていただきます。よろしくお願いいたします。

タイトル「シートA」と「シートB」を比較して抜けてるデータを「シートB」に入力
がしたいのですが、なかなかやり方が思いつきません。

シートAとシートBのデータ項目として下記の項目があります。
住所・氏名・部署・担当・電話番号・アドレス・評価・備考
同じ氏名の人の内容はシートAに入力されることにより更新をかけれるようにしたいです。

シートBは編集不可でシートAに入力した内容をシートBに写す形にしたいのです。
ただ、シートBには月1～2回程度で上の部署からデータが入力されていきます。
それ以外のデータをシートAで入力していき、最終的にシートBにシートAの内容を反映させたいのです。
手で入力していたのですが、シートBは毎月更新でシートAは毎日更新される為、簡略化できればとおもいご相談させていただきました。
ただし、一度入力されたデータで
住所・氏名・部署・担当・アドレス　まで入力されていて
翌日に　評価・備考を入力する。
また、後日電話番号が判明した時に入力される様に必ずしも全項目同じ日に入力されていることはありません。
シートAに入力されたら、その抜けてる項目をシートBにも反映させるようにするにはどうしたらよろしいでしょうか？
関数であれVBAであれ、ご教授お願いします。
うまくまとまっていなくて読みにくい事かと思いますが、よろしくお願いいたします。

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

シートBにVLOOKUPの数式を入力しておくとか？

（マナ） 2018/10/07(日) 18:29

ＶＢＡなら様々な方法が有ると思いますが一案として
概略、下記の様な感じで出来るかと思います。。。ただ。。。。。
＞＞シートBは編集不可でシートAに入力した内容をシートBに写す形にしたいのです。
＞＞ただ、シートBには月1～2回程度で上の部署からデータが入力されていきます。
の相反する二点がすごぉ～く気になりますが。。。　＾＾；

1.変数等、定義
2.読込シートを１行毎に変数に読み込む
3.読込んだ行の名前が書込み先シートに有るか調べる。
4.有れば見つかった書込み先の名前の行に読込んだ行を上書きする。
5.無ければ書込み先シートの最終行に追加書込みする。
6.2～5を読込先の最終行まで繰り返す。
（隠居じーさん） 2018/10/08(月) 20:20

マナさん、隠居じーさんさんありがとうございます。
こちらの説明不足と矛盾点があり申し訳ありません。
シートBについてですがは編集不可の部分は手入力せずという意味でしたが
改めて読み直して自分でも何を書いていたのか困惑してしまいました。
要はシートAの内容をシートBに反映させたい、この点につきます。

隠居じーさんさんのVBAの流れは実際入力するとなると
どういう感じになるのでしょうか？よろしくお願いいたします。

（ころまる） 2018/10/08(月) 23:36

 初めに必ず入力される必須項目は決まってるんですか？
 それが決まってないと数式でもマクロでも判断が出来ないので読み込む事は不可能です。

 初めの必須項目が決まってるなら、シートAのデータをシートBの下に追加で全データコピペして、
 必須項目をキーにして重複の削除を実行で良いと思います。
 シートBに重複データが存在すれば無理ですが、名簿っぽいので大丈夫かなと。

 手作業でも1～2分の作業ですが、面倒ならマクロ記録を取ってショートカットに登録しておけば良いです。

（sy） 2018/10/09(火) 06:13

 おはようございます。　＾＾
syさんがご指摘ですが、確かに。。。ユニークなKeyが有った方が良いですね。
ご提示の項目から推測するとどれも1意とは言えないような気がいたします。
例。。。
同姓同名
同居
メルアド共有
寮、等で同電話番号
携帯、持っていない＾＾；
など
不測の事態が起こりやすい様に推測されます。（きっと起こる^^;;;）
解決方法（完全とは言えませんが、無いよりはず～といいです。）
ユニークなKEYコードを使う、無ければ、新設する。。。
例えば社員コードの様な　
何はなくともkeyコードさえ入力しておけばあとはルンルン　みたいな。
強くお勧め致します。
以下、名前をKEYに設定した不測の事態を起こしかねないコードですが。。。
なにかお勉強の足しにでもkeyコードに。。。、KEYを変えてくださいね。

 Option Explicit
Sub main_v2()
    Dim sh01 As Worksheet, sh02 As Worksheet
    Dim rrA As Range, rA As Range, lrA As Long, lrB As Long
    Dim rrB As Range, fr As Range
    Set sh01 = Worksheets("A")
    Set sh02 = Worksheets("B")
    lrA = sh01.Cells(sh01.Rows.Count, 2).End(xlUp).Row - 1
    lrA = IIf(lrA < 1, 1, lrA)
    Set rrA = sh01.Range("A1").CurrentRegion.Offset(1).Resize(lrA)
    If WorksheetFunction.CountA(rrA) < 1 Then Exit Sub
    If WorksheetFunction.CountA(sh02.Rows(1)) = 0 Then
        sh01.Rows(1).Copy sh02.Cells(1)
    End If
    Set rrB = sh02.Range("A1").CurrentRegion
    lrB = sh02.Cells(sh02.Rows.Count, 2).End(xlUp).Row
    For Each rA In rrA.Rows
        If WorksheetFunction.CountA(rA) Then
            Set fr = rrB.Columns(2).Find(what:=rA.Cells(2), LookIn:=xlValues, lookat:=xlWhole)
            If Not fr Is Nothing Then
                rA.Copy
                sh02.Cells(fr.Row, 1).PasteSpecial (xlValues)
            Else
                rA.Copy
                sh02.Cells(lrB + 1, 1).PasteSpecial (xlValues)
                lrB = lrB + 1
            End If
        End If
    Next
    Application.CutCopyMode = False
End Sub

（隠居じーさん） 2018/10/09(火) 08:56

ころまる　さん　済みません
（隠居じーさん） 2018/10/09(火) 08:56
のコードには不備があります。廃案でお願いいたします。
修正出来たら又。アップしますね。
暫くお待ちください。

（隠居じーさん） 2018/10/09(火) 09:06

 名前がKYEと云いながら何でも有ればコピーしていました。＾＾；　（必須バックアップ）
。。。危険なコードで有ることに変わりはありません。
m(_ _)m..... でわ

 Option Explicit
Sub main_v2()
    Dim sh01 As Worksheet, sh02 As Worksheet
    Dim rrA As Range, rA As Range, lrA As Long, lrB As Long
    Dim rrB As Range, fr As Range
    Set sh01 = Worksheets("A")
    Set sh02 = Worksheets("B")
    lrA = sh01.Cells(sh01.Rows.Count, 2).End(xlUp).Row - 1
    lrA = IIf(lrA < 1, 1, lrA)
    Set rrA = sh01.Range("A1").CurrentRegion.Offset(1).Resize(lrA)
    If WorksheetFunction.CountA(rrA) < 1 Then Exit Sub
    If WorksheetFunction.CountA(sh02.Rows(1)) = 0 Then
        sh01.Rows(1).Copy sh02.Cells(1)
    End If
    Set rrB = sh02.Range("A1").CurrentRegion
    lrB = sh02.Cells(sh02.Rows.Count, 2).End(xlUp).Row
    For Each rA In rrA.Rows
        If WorksheetFunction.CountA(rA) And rA.Cells(2) <> "" Then
            Set fr = rrB.Columns(2).Find(what:=rA.Cells(2), LookIn:=xlValues, lookat:=xlWhole)
            If Not fr Is Nothing Then
                rA.Copy
                sh02.Cells(fr.Row, 1).PasteSpecial (xlValues)
            Else
                rA.Copy
                sh02.Cells(lrB + 1, 1).PasteSpecial (xlValues)
                lrB = lrB + 1
            End If
        End If
    Next
    Application.CutCopyMode = False
End Sub
（隠居じーさん） 2018/10/09(火) 10:06

コメント返信：

[ 一覧(最新更新順) ]

[[20181007171923]] 『「シートA」と「シートB」を比較して抜けてるデー』（ころまる） ページの最後に飛ぶ

[[20181007171923]]　『「シートA」と「シートB」を比較して抜けてるデー』（ころまる）　ページの最後に飛ぶ