同じ雛型を使った３つのエクセルの統合です。

質問

同じ雛型を使った３つのエクセルの統合です。

こんにちは、初めて質問をさせていただきます。当方マクロやVBAを使いはじめたばかりで、必死に勉強をしている最中なのですが、取り急ぎ必要なものができてしまい、こちらに質問させていただくことにしました。

現在３人の人間が同じリストを使って作業をしているのですが（名簿のようなものです）この３つをその日その日で統合したひとつのリストにまとめたいのです。状況という項目もあり、その項目は日々更新されていく可能性のあるセルになります。簡単に下に状況をまとめました。

Ａさんのシート　（A001を書き換えた）
　　　　更新日　　　状況　　　備考
A001　　4/11　　　　○　　　　4/7入電　4/8交換　4/11再度電話
A002　　空欄　　　　空欄　　　空欄
A003　　4/7　　　　　●　　　　4/7ご案内

Ｂさんのシート　（A002を書き換えた）
　　　　更新日　　　状況　　　備考
A001　　4/11　　　　○　　　　4/7入電　4/8交換
A002　　4/12　　　　×　　　　4/12連絡なし
A003　　4/7　　　　　●　　　　4/7ご案内

Ｃさんのシート　（何も更新なし）
　　　　更新日　　　状況　　　備考
A001　　4/11　　　　○　　　　4/7入電　4/8交換
A002　　空欄　　　　空欄　　　空欄
A003　　4/7　　　　　●　　　　4/7ご案内

理想の統合状態
　　　　更新日　　　状況　　　備考
A001　　4/11　　　　○　　　　4/7入電　4/8交換　4/11再度電話
A002　　4/12　　　　×　　　　4/12連絡なし
A003　　4/7　　　　　●　　　　4/7ご案内

基本的にひとつのセルを２人の人間が更新する事はまれなのですが、もしそうなった場合、内容を精査した上で一つのシートにまとめたいので、３つの内容がバラバラだった場合、行番号がわかるようなものが組めたらいいなと思っています。

色々と我儘放題書きましたが、このような事は可能なのでしょうか？また、どのようなVBAになるのでしょうか？ご享受いただけましたら幸いです。

回答No.4

qwerjpo

追記：
あのコードは標準モジュールに貼り付けてください。
（たぶんわかってると思うけど。一応。）

回答No.3

qwerjpo

すみません、文字制限ぎりぎりだったのでこちらで解説させていただきます。

まず、そちらの環境に合わせて変えてもらう所が一カ所あります。

'それぞれのシート名を変えてください
Const S1 = "シート１"
Const S2 = "シート２"
Const S3 = "シート３"
Const S4 = "集計シート"

の部分です。ここのシート名を変えてください。

それと、注意点ですが、
このマクロはそれぞれの人のリストが同一ブック内にあることを前提としているので、
違う場合は言っていただくか、もしくは同一ブック内にコピーor移動などして利用してください。

また、このマクロは1番目のシートの1列目の最終行を全体の最終行としているので、違う場合は該当箇所をご自分で修正してください。（簡単な所なので）

なにかバグがあったり、うまくいかなかったりした場合には直すので言ってください。
カスタマイズしてほしいという場合でも一応受け付けます。
ただ簡単な所は自分でやってください。勉強のためですから（笑

回答No.2

qwerjpo

Type RowsItem
UpDate As String
Situation As String
Remarks As String
End Type

Sub TotalSheet()

'それぞれのシート名を変えてください
Const S1 = "シート１"
Const S2 = "シート２"
Const S3 = "シート３"
Const S4 = "集計シート"

Dim RowCnt As Long,SheetCnt As Integer,LastRow As Long
Dim Sheet1 As RowsItem,Sheet2 As RowsItem,Sheet3 As RowsItem
Dim UpDate As String,Situation As String,Remarks As String

'最終行取得
LastRow = Worksheets(S1).Range("a65536").End(xlUp).Row
RowCnt = 2
Worksheets(S4).Activate

Do
'それぞれのシートの値を取得
With Worksheets(S1)
Sheet1.UpDate = .Range("B" & RowCnt).Text
Sheet1.Situation = .Range("C" & RowCnt).Value
Sheet1.Remarks = .Range("D" & RowCnt).Value
End With
With Worksheets(S2)
Sheet2.UpDate = .Range("B" & RowCnt).Text
Sheet2.Situation = .Range("C" & RowCnt).Value
Sheet2.Remarks = .Range("D" & RowCnt).Value
End With
With Worksheets(S3)
Sheet3.UpDate = .Range("B" & RowCnt).Text
Sheet3.Situation = .Range("C" & RowCnt).Value
Sheet3.Remarks = .Range("D" & RowCnt).Value
End With
'更新日
If Sheet1.UpDate <> "" Then
UpDate = Sheet1.UpDate
ElseIf Sheet2.UpDate <> "" Then
UpDate = Sheet2.UpDate
ElseIf Sheet3.UpDate <> "" Then
UpDate = Sheet3.UpDate
End If
'状況
If Sheet1.Situation <> "" Then
Situation = Sheet1.Situation
ElseIf Sheet2.Situation <> "" Then
Situation = Sheet2.Situation
ElseIf Sheet3.Situation <> "" Then
Situation = Sheet3.Situation
End If
'備考
Remarks = ""
If Sheet1.Remarks <> "" Then
Remarks = Sheet1.Remarks
End If
If Sheet2.Remarks <> "" And InStr(Remarks, Sheet2.Remarks) = 0 Then
If Remarks <> "" Then
Remarks = Remarks & " " & Sheet2.Remarks
Else
Remarks = Sheet2.Remarks
End If
End If
If Sheet3.Remarks <> "" And InStr(Remarks, Sheet3.Remarks) = 0 Then
If Remarks <> "" Then
Remarks = Remarks & " " & Sheet3.Remarks
Else
Remarks = Sheet3.Remarks
End If
End If
'集計シートに書き出し
With Worksheets(S4)
.Range("B" & RowCnt).Value = UpDate
.Range("C" & RowCnt).Value = Situation
.Range("D" & RowCnt).Value = Remarks
End With
RowCnt = RowCnt + 1
Loop Until RowCnt > LastRow
End Sub

回答No.1

qwerjpo

初心者だったらちょっと難しいんじゃないかな？
まぁ、できないことはないけど。

まずは全ての書式を統一してください。
（備考の日付は半角にする、更新日の書式は文字列or日付にする、など。）

ソースは・・・・後で書きます。