各シートからの特定位置セルの抜き出し→一覧作成 手段

質問

お世話になります。

20近いシートで構成されるエクセルファイルにおいて、各シートのタイトル部（シートの位置として、Ａ-2）だけを抜き出して、一覧表にしたいと考えています。

いちいちコピペするのではなく、関数などで、一気に処理できれば、とても助かるのですが、何か良い方法はないでしょうか。

よろしくお願い致します。

回答No.1

mshr1962 · ベストアンサー

シート名を
1行目に記入
A2=INDIRECT(A1&"!A2")

お礼

ありがとうございました。おかげ様で、うまくいきました。
関数というのは、やはり知っているととても便利ですね。一応、本では調べたつもりだったのですが、うまく見つけられなかったところだったので、とても助かりました。ありがとうございます。

それにしても、シート名をもっとシンプル＆規則性のあるものにしておけばよかったと後悔しています。
トホホ・・・

回答No.3

fly_moon

NO2です。

すいません。コピーはこちらのものを使ってください。

'コピー開始位置-------------

Sub タイトル一覧表作成()

On Error GoTo Err
Dim newflg As Boolean
Dim upflg As Byte
Dim ws As Worksheet
Dim r As Long
Dim itiran As Worksheets

'設定開始------------------------------------------------------
Dim newSheetName As String
Dim col As String
Dim TitleRange As String

'新しく作成されるシート名
newSheetName = InputBox("一覧表を作成するシート名を入力") '"タイトル一覧表"

'開始行
r = InputBox("開始行を入力") '1

'列
col = InputBox("列のアルファベットを入力") '"A"

'各シートのタイトルのあるアドレス
TitleRange = "A2"

'-------------------------------------------------------設定終了
Set ichiran = Sheets(newSheetName)

For Each ws In Worksheets
If ws.Name <> newSheetName Then
ichiran.Range(col & r) = ws.Range(TitleRange)
r = r + 1
End If
Next
Exit Sub

Err:
If Err.Number = 9 Then
Worksheets.Add.Name = newSheetName
newflg = True
Resume
Else
MsgBox Err.Description
'MsgBox "失敗しました。もう一度最初からやり直してください。"
End If

End Sub

'コピー終了位置--------------------

いらないものを削除中にいるものも削除しちゃってました。(^_^;)

お礼

とても丁寧なアドバイス、ありがとうございました。

いやぁ、すごいんですね、ＶＢＡって。
確かに、教えたいただいた通りにやったら
一気に一覧ができました。

こんなの自分で書けたら、
すごく楽なんだろうなぁと(^_^;) 、
そんなイメージの湧かない将来を考えたり
してました。

また、よろしくお願い致します。

回答No.2

fly_moon

VBAマクロを作成すれば、スイスイですよ。

(1)[ツール]→[マクロ]→[新しいマクロの記録]で[マクロの記録]ダイアログBOXが開きます。マクロ名：を覚えておいて[OK]で開始します。

(2)何の処理もせず、すぐに又、
[ツール]→[マクロ]を開くと今度は[記録終了]が出てきますのでクリックしてください。

(3)次に
[ツール]→[マクロ]→[マクロ]を開き、さっき覚えたマクロ名を選択して[編集]をクリックします。

(4)VBAの画面が開きますので、一番下に下記コードをここからコピーして、貼り付けます。

'コピー開始位置---------------------
Sub タイトル一覧表作成()

On Error GoTo Err
Dim newflg As Boolean
Dim upflg As Byte
Dim ws As Worksheet
Dim r As Long
Dim itiran As Worksheets

'設定開始------------------------------------------------------
Dim newSheetName As String
Dim col As String
Dim TitleRange As String

'新しく作成されるシート名
newSheetName = "タイトル一覧表"

'開始行
r = 1

'列
col = "A"

'各シートのタイトルのあるアドレス
TitleRange = "A2"

'-------------------------------------------------------設定終了

For Each ws In Worksheets
If ws.Name <> newSheetName Then
ichiran.Range(col & r) = ws.Range(TitleRange)
r = r + 1
End If
Next
Exit Sub

Err:
If Err.Number = 9 Then
Worksheets.Add.Name = newSheetName
newflg = True
Resume
Else
MsgBox "失敗しました。もう一度最初からやり直してください。"
End If

End Sub

'コピー終了位置--------

(5)保存した後VBAの画面を閉じます。

(6)[ツール]→[マクロ]→[マクロ]を開き、さっき覚えたマクロ名を選択して[削除]をクリックします。

(7)[ツール]→[マクロ]→[マクロ]を開き、「タイトル一覧表作成」を選択して[実行]をクリックします。

新しい「タイトル一覧」シートが作成され、BOOK内の全てのシートの"A2"セルの値が縦に入力されます。

一度試してみてください。