2枚のエクセルのシートを図のように統合させる

質問

2枚のエクセルのシートを統合させるやり方を教えて下さい。
(同じ項目に２人の人が答えている場合2行に分けることはできますか。)

以前こちらで質問させていただいたとき、

Sub test()

Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet
Set Sh1 = Workbooks("book1.xls").Sheets("Sheet1")
Set Sh2 = Workbooks("book2.xls").Sheets("Sheet1")
Set Sh3 = Workbooks("book3.xls").Sheets("Sheet1")

Sh1.Range("B5").CurrentRegion.Copy Sh3.Range("B5")
With Sh2.Range("B5").CurrentRegion
.Resize(.Rows.Count - 1).Offset(1).Copy Sh3.Cells(Sh3.Rows.Count, "B").End(xlUp).Offset(1)
End With

With Sh3
Dim r As Long
For r = .Cells(.Rows.Count, "B").End(xlUp).Row To 6 Step -1
If .Cells(r, "C").Value = "" Then .Rows(r).Delete
Next r
.Range("B5").CurrentRegion.Sort Key1:=.Range("B6"), Order1:=xlAscending, Header:=xlYes
For r = .Cells(.Rows.Count, "B").End(xlUp).Row To 6 Step -1
If .Cells(r, "B").Value = .Cells(r - 1, "B").Value Then .Cells(r, "B").ClearContents
Next r

End With
End Sub

というコードを教えていただいたのですが、項目の中があいうえお順になってしまいうまくいきません。
そして、途中に項目があったりしてこれは１つだけ表示されるようにできますか？
説明が足りないところは、補足いたします。

いきなり部署を異動させられて今までやったことないようなことをやっています(涙)
どなたか教えて下さいよろしくお願いします。

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.2

imogasi

画像ではデータの情況がよく読めない。テキストで質問にコピペしてほしい。
ーー
こういうVBAコードのコピペしか出来ない人の質問は、第２波が来ることが多い。
A表＋B表の上部の部分を上部の部分２つ同志でまとめ、
下の部分を下部の部分２つ同志でまとめることで良いようなのだが、どうなのかな。
ーー
こんなもの手作業で貼り付けて好みの順序に並べ替えれば仕舞いではないのか？
Sheet1
1た 鈴木 イ
2ち
3つ 鈴木 ハ
4て 鈴木 ニ
5と 鈴木 ホ
Sheet2　本当はブックが別かもしれないが同じと思う
1た
2ち 田中 ロ
3つ
4て
5と 田中 へ
Sheet3でSheet1をコピペ、その下にへえｔ２をコピペ
1た 鈴木 イ
2ち
3つ 鈴木 ハ
4て 鈴木 ニ
5と 鈴木 ホ
1た
2ち 田中 ロ
3つ
4て
5と 田中 へ
A列で並び替え
1た 鈴木 イ
1た
2ち
2ち 田中 ロ
3つ 鈴木 ハ
3つ
4て 鈴木 ニ
4て
5と 鈴木 ホ
5と 田中 へ
ここでフィルタをかけて、B列で、▼をクリックし、（空白以外のセル）を条件で選択
見た目
1た 鈴木 イ
2ち 田中 ロ
3つ 鈴木 ハ
4て 鈴木 ニ
5と 鈴木 ホ
5と 田中 へ
編集ージャンプーセル選択ー可視セルーOK
他のせる範囲に貼り付け
結果
1た 鈴木 イ
2ち 田中 ロ
3つ 鈴木 ハ
4て 鈴木 ニ
5と 鈴木 ホ
5と 田中 へ
これで良いのでは。
ーーー
下の２つの部分も上下部分に貼り付けてA列でソート
１か 鈴木 a
１か 田中 x
２き 鈴木 b
２き 田中 y
３く 鈴木 c
３く 田中 z
４け 鈴木 d
４け 田中 u
５こ 鈴木 e
５こ 田中 v
A列で「１か」などが、ダブって見えるので、これがイヤなら
条件付書式で
全体範囲を選択し
CTRLキーを押しながらA3をクリック。A3がアクチブになる。
そこで「数式が」で、式に=A3=A2
書式で、フィントを白色に設定。
これで３，５，７，９行のA列は見た目で見えなくなる。
ーー
これでよいのではないですか。VBAでこれをVBAにするとかは可能。
マッチングのロジックでマージするとかできるが、質問者のレベルを超えている。
ーー
ここで出来ましたなんて、VBAなどで取り繕うと、今後困ったことになりはせんですか。
質問者は出来るものだと誤解されて、まもなくばれるときが恐ろしいように思うが。

補足

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

実際は、行が100くらいあり、それが5人分あります。
私は、今子育てで時短勤務をしており、会社に復帰したばかりです。

上司からこの統合作業を2時間でやれと言われています。

この作業は月に1回あるのですが、慣れていないためコピーペーストで
やって1日かかってしまい、残業になってしまいます。

子供がいなければ、残業もかまわないのですが保育園の迎えがあり、それも叶いません。。

ソートするやり方も考えたのですが、エクセルが全く使えないおじいちゃん社員にもわかるように作れと言われ、

マクロを組んでボタンひとつで統合されれば、私がいなくなってからもできるかなと思い質問した次第でございます。

しかしながら私には難しく、知識をはるかに越えておりました。

くだらない質問を二度もして申し訳ありませんでした。

回答No.1

yy_kd

同じBook内のシートの合成でしたら下記コードで大丈夫な様です。
シート１、２をシート３に合成する場合を考えて見ました。

Sub Macro1()
Sheets("sheet1").Select
Cells.Select
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
sy = 8: dy = 8
While Sheets("sheet2").Cells(sy, "B") > ""
If Sheets("sheet2").Cells(sy, "C") > "" And Sheets("sheet3").Cells(dy, "C") > "" Then
dy = dy + 1
Sheets("sheet3").Select
Sheets("sheet3").Rows(dy).Select
Selection.Insert Shift:=xlDown
For x = 3 To 4
Sheets("sheet3").Cells(dy, x) = Sheets("sheet2").Cells(sy, x)
Next
ElseIf Sheets("sheet2").Cells(sy, "C") > "" And Sheets("sheet3").Cells(dy, "C") = "" Then
For x = 3 To 4
Sheets("sheet3").Cells(dy, x) = Sheets("sheet2").Cells(sy, x)
Next
ElseIf Sheets("sheet2").Cells(sy, "C") = "" And Sheets("sheet3").Cells(dy, "C") > "" Then

End If
sy = sy + 1: dy = dy + 1
Wend
Range("B5:D" & dy - 1).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Cells(5, "B").Select
End Sub