Excelで異なるブック間での同一シートの共有

質問

• Excelで異なるブック間で同一シートの共有をする方法について教えてください。
• ExcelBook1.xlsからExcelBook3.xlsまでのブックで同じシートを共有する方法について知りたいです。
• ExcelBook1.xlsからExcelBook3.xlsまでのブックをSummaryBook.xlsでまとめて閲覧することは可能でしょうか？

回答No.2

x0000x · ベストアンサー

#1です。

>基本的にシートの構成はみな同じなので、
>セル参照などとVBAを組み合わせればきっと可能なのでしょうが、

ご希望のイメージと違うかも知れませんが、
VBAなら以下の通りです。

<処理の条件>
SummaryBook.xlsをOPENする際、SummaryBook.xlsのSheet1に
ExcelBook1.xls ～ ExcelBook3.xlsの各Sheet1を順に読込ます。
この読込の際、HyperLinkのアドレスを変更します。
（ただし、HyperLinkが格納されている列は”C列”にしてあります。）

以下コードです。
SummaryBook.xlsのマクロとして登録します。
Alt+F11で表示させ、ThisWorkbookを開き、コードを貼り付けます。

”★”コメントを任意に変更した上で、お試しを！！

'WorkbookのOpenEvent
Private Sub Workbook_Open()

'Summary Bookの一覧表シートをSheet１に設定します。
Dim summarySheet As Worksheet
Set summarySheet = ActiveWorkbook.Worksheets("Sheet1") '★Summrybookのシート名

'一覧表をクリアする。
summarySheet.Cells.Select
Selection.ClearContents

'セルをCopyする
Dim setRowIndex As Long

'★以下のcopyCells()の引数を変更。順番は、対象ブックのPATH、ブック名、シート名、読込開始行、格納行、summarybookのシート
setRowIndex = copyCells("フォルダ1\", "ExcelBook1.xls", "Sheet1", 1, 1, summarySheet)
setRowIndex = copyCells("フォルダ2\", "ExcelBook2.xls", "Sheet1", 1, setRowIndex, summarySheet)
setRowIndex = copyCells("フォルダ3\", "ExcelBook3.xls", "Sheet1", 1, setRowIndex, summarySheet)

'終了
Set summarySheet = Nothing
End Sub

Private Function copyCells(ByVal path As String _
, ByVal bookNM As String _
, ByVal sheetNM As String _
, ByVal CopyRowIndex As Long _
, ByVal setRowIndex As Long _
, ByVal listSheet As Worksheet) As Long

'指定されたブックの指定シートを一覧シートにコピーする。
'Args path : Copy元の格納PATH　…文字列の最後は"\"で終了
' bookNM : Copy元のブック名 … Path + ブック名で指定
' sheetNM : Copy元のシート名
' CopyRowIndex : Copy元の開始行　　…　最初は見出し行を指定、2回目からはデータの先頭を指定
' setRowIndex : 一覧に格納する開始行位置
' listSheet : 一覧表シート

'画面更新を止める
Application.ScreenUpdating = False

const colHyperlink as String = "C" '★HyperLink列　確認
Dim srcBK As Workbook
Dim srcST As Worksheet
Set srcBK = Workbooks.Open(path & bookNM)
Set srcST = srcBK.Sheets(sheetNM)

If setRowIndex = 1 Then

'最初のCopyでは、列幅もCopy元にあわせる
srcST.Cells.Copy Destination:=listSheet.Range("A" & setRowIndex)

Else

'2回目以降は行単位でCopyする
Dim maxRowIndex As Long
maxRowIndex = srcST.Rows(srcST.Rows.Count).End(xlUp).row '格納最終行を求める

srcST.Rows(CopyRowIndex & ":" & maxRowIndex).Copy Destination:=listSheet.Range("A" & setRowIndex)

End If

'一覧表内で次に格納可能な行を戻す。
copyCells = listSheet.Rows(srcST.Rows.Count).End(xlUp).row + 1

Dim row As Long
For row = setRowIndex To copyCells - 1 '格納最大まで
If listSheet.Cells(row, colHyperlink).Hyperlinks.Count > 0 Then
'リンクが存在した場合にアドレスを変更する
Dim cnt As Integer
For cnt = 1 To listSheet.Cells(row, colHyperlink).Hyperlinks.Count

'HyperlinkのアドレスにPATHを付加し、Summarybook.xlsからの参照を可能にする
listSheet.Cells(row, colHyperlink ).Hyperlinks(cnt).Address _
= path & listSheet.Cells(row, colHyperlink).Hyperlinks(cnt).Address

Next
End If
Next

'ブックを閉じる(更新なし）
srcBK.Close SaveChanges:=False

Set srcST = Nothing
Set srcBK = Nothing

'画面更新を復活
Application.ScreenUpdating = True

End Function

お礼

結果報告です。

'★以下のcopyCells()の引数を変更。順番は、対象ブックのPATH、ブック名、シート名、読込開始行、格納行、summarybookのシート
setRowIndex = copyCells("ex1\", "ex1.xls", "happysheet", 1, 1, summarySheet)

とセットし、保存してファイルを開こうとしますと、

実行時エラー '1004':
'ex1\ex1.xls'が見つかりません。
ファイル名およびファイルの保存場所が正しいかどうか確認してください。

というエラーが出てしまい、デバッグすると
下記の行がハイライトされてしまいます。

Set srcBK = Workbooks.Open(path & bookNM)

フォルダもファイルもきちんと存在していますし、
上記の位置（SummaryBook.xlsと同じ階層にフォルダがあり、
ex1\ex1.xlsが相対パスとして正しいと思うのですが、
別のフォルダーを指定してもやはり同じ結果で、
最初に読み込もうとする行でつまいでしまいます。

こんなに書いていただいて本当に申し訳ないのですが、
どうやら私にはやはりこのように長くて複雑なマクロで、
というのはまだまだ難しすぎる作業だと痛感しました・・・。

今回いただいたアドバイスは、ちゃんと保存しておいて、
いつかもっと腕を磨いてからまた挑戦させていただきたいと思います。

本当にありがとうございました！

補足

うう、感激です。本当にありがとうございます。
お返事が遅れ、大変失礼いたしました。
実は今引越し中でネット・パソコン環境がまだ整っていないのですが
近日中に今回作っていただいたコードにじっくりと
取り組んで、勉強させていただき、結果報告をさせていただきます。
本当にありがとうございました！！！