Excel,VBA シートの自動作成、データ

質問

Sheet 1 に住所録
Sheet 2～50までに同じフォーマットで
A 　B　　C～E F～H
No. 名前 S～L S～L

と並んでいてA4から名前　C～の列には各数量が50行ほど入力されています。

Sheet 2～50 までを名前ごとにまとめたSheet を自動で作成したいです。
Sheet1とSheet2～50の名前順は同じです。

例 Sheet51 シート名 Aさん
　　　DEF列
　　　SML
1行目1,2,3(Sheet2AさんのC～E数量)
2行目2,2,2(Sheet2AさんのF～G数量)
3行目2,2,2(Sheet3AさんのC～E数量)
4行目4,4,4(Sheet3AさんのF～G数量)

同じようにSheet 53　Bさん
となるようにループする方法をご教授ください。

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

回答No.11

kagakusuki

>J列に表示させる内容をC列に表示させる、という内容でお願い致します。

　それでしたら、

ReDim OutputColumn((UBound(mySize) + 1))
i = 0
For Each c In Range(FirstOutputColumn & 1).Resize(1, UBound(OutputColumn) + 1)
i = (i + 1) Mod (UBound(OutputColumn) + 1)
OutputColumn(i) = c.Address(True, False)
OutputColumn(i) = Left(OutputColumn(i), InStr(OutputColumn(i), "$") - 1)
Next c

となっている箇所を

ReDim OutputColumn((UBound(mySize) + 1))
OutputColumn(0) = "C" '各氏名と同名のシートにおいて、どの元データのシートの何列から何列までのカウント結果であるのかを表記する文字列を入力する列の列番号
i = 1
For Each c In Range(FirstOutputColumn & 1).Resize(1, UBound(OutputColumn))
OutputColumn(i) = c.Address(True, False)
OutputColumn(i) = Left(OutputColumn(i), InStr(OutputColumn(i), "$") - 1)
i = i + 1
Next c

に変更し、「'住所録にある名前と同じシート名のシートにカウント結果を入力」と「'label1をジャンプ」の間にある部分を

For i = mySheet(3).Index + 1 To Sheets.Count
With Sheets(i)
If WorksheetFunction.CountIf(NameRange, .Name) > 0 Then
With .Range(OutputColumn(1) & FirstOutputRow - 1)
If .Formula = "" Then .Formula = "="""""
End With
For j = mySheet(2).Index To mySheet(3).Index
With .Range(OutputColumn(1) & Rows.Count).End(xlUp)
For k = 0 To UBound(SearchColumn)
myOffset = k Mod (UBound(mySize) + 1)
With .Offset(1 + Int(k / (UBound(mySize) + 1)))
With .Parent.Range(OutputColumn(0) & .Row)
Select Case myOffset
Case 0
.Value = Sheets(j).Name & "の" & SearchColumn(k) & "列～"
Case UBound(mySize)
.Value = .Value & SearchColumn(k) & "列の" & .Parent.Name & "の数量"
End Select
End With
With .Offset(, myOffset)
.Value = .Value + WorksheetFunction.SumIf(Sheets(j).Columns(NameColumn), _
Sheets(i).Name, Sheets(j).Columns(SearchColumn(k)))
End With
End With
Next k
End With
Next j
End If
With .Range(OutputColumn(1) & FirstOutputRow - 1)
If .Formula = "=""""" Then .Formula = ""
End With
.Columns(OutputColumn(0)).AutoFit
End With
Next i

に変更してみて下さい。

お礼

kagakusuki 様

以前は大変お世話になりました。

作成していただいたVBA について質問が御座います。

>Sheet 2～50までに同じフォーマットで
>A 　B　　C～E F～H
> No. 名前 S～L S～L

と書かれていたため、「S～Lの様なサイズが網羅された列のセット」が2セット(「C～E列」と「F～G列」の2組)存在している場合に対応させる様にしかしておらず、3セット以上存在している場合にまで対応させなければならなくなる様な事は想定しておりませんでした。
　ですから、

>「C～H」「I～N」この繰り返しが「AA～AF」まで

の様に、5セットも存在している場合に対応させようとしますと、エラーが発生します。

こちらを今回は6セットに変更したいと考えております。
お手透きの際にご教授お願い致します。

http://okwave.jp/qa/q9171910.html

こちらの質問欄でご回答お待ちしております。

回答No.10

kagakusuki

回答No.9に対して質問者様が投稿された補足コメントの内容が今一つ不明瞭ですので、2、3点確認したい事が御座います。

>フォーマットのJ～L列に文字またはオートSUMが入力されているとエラーになってしまいます。

　回答No.6と7で御伝えしたマクロはD列～J列の7行目以下にカウント結果の値を入力するだけで、フォーマットのシートのセルに入力されている情報は一切利用していないため、フォーマットのシートにどの様な値が入力されていたとしてもその事には影響されませんので、フォーマットの状況によってマクロがエラーになるとは考えられません。
　ですからそれはマクロが処理の途中でエラーになったという事ではなく、フォーマットに質問者様が入力されたワークシート関数がエラーになったという事ではないでしょうか？
　そして、マクロによる処理を行った後も、質問者様のワークシート関数がエラーにならない様にするために、「値を上書きする列としてJ列は使用しない様にして欲しい」というのが質問者様の御要望の趣旨と考えれば宜しいのでしょうか？

>こちらをC列、もしくは表示させずにフォーマットのオートSUMや文字を残す方法をご教授いただけますでしょうか。

との事ですが、もし表示させないとなりますと、どのシートの何列から何列までのカウント結果なのかをどの様に区別出来る様にすれば良いと仰るのでしょうか？

>こちらをC列、もしくは表示させずに

という表現は文脈が成り立っておらず、「こちらをC列」という部分が意味不明なものとなっていますが、もしかしますと、
「現在はJ列に表示される様になっている内容を、J列ではなくC列に表示される様にするか、もしくは表示させない様にする事で、フォーマットシートのJ列に入力されているSUM関数や文字を残す様にして欲しい」
と仰りたいのでしょうか？

補足

ご返信ありがとうございます。

＞「現在はJ列に表示される様になっている内容を、J列ではなくC列に表示される様にするか、もしくは表示させない様にする事で、フォーマットシートのJ列に入力されているSUM関数や文字を残す様にして欲しい」
と仰りたいのでしょうか？

＞もし表示させないとなりますと、どのシートの何列から何列までのカウント結果なのかをどの様に区別出来る様にすれば良いと仰るのでしょうか？

kagakusuki 様の解釈の通りでございます。J列に表示させる内容をC列に表示させる、という内容でお願い致します。

説明不足で申し訳ございません。

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

回答No.9

kagakusuki

回答No.8の続きです。

'住所録にある名前と同じシート名のシートにカウント結果を入力
For i = mySheet(3).Index + 1 To Sheets.Count
With Sheets(i)
If WorksheetFunction.CountIf(NameRange, .Name) > 0 Then
With .Range(OutputColumn(1) & FirstOutputRow - 1)
If .Formula = "" Then .Formula = "="""""
End With
For j = mySheet(2).Index To mySheet(3).Index
With .Range(OutputColumn(1) & Rows.Count).End(xlUp)
For k = 0 To UBound(SearchColumn)
myOffset = k Mod (UBound(mySize) + 1)
With .Offset(1 + Int(k / (UBound(mySize) + 1)))
With .Offset(, UBound(OutputColumn))
Select Case myOffset
Case 0
.Value = Sheets(j).Name & "の" & SearchColumn(k) & "列～"
Case UBound(mySize)
.Value = .Value & SearchColumn(k) & "列の" & .Parent.Name & "の数量"
End Select
End With
With .Offset(, myOffset)
.Value = .Value + WorksheetFunction.SumIf(Sheets(j).Columns(NameColumn), _
Sheets(i).Name, Sheets(j).Columns(SearchColumn(k)))
End With
End With
Next k
End With
Next j
End If
With .Range(OutputColumn(1) & FirstOutputRow - 1)
If .Formula = "=""""" Then .Formula = ""
End With
.Columns(OutputColumn(0)).AutoFit
End With
Next i

'label1をジャンプ
GoTo labelEnd

'住所録に入力されている氏名の中にシート名として使用できない文字列かあった場合の処理
label1:
With c.Font
.Strikethrough = True
.Color = 255
End With
c.Interior.Color = 65535
UnusableName = UnusableName & vbCrLf & c.Value
Return

'停止していたマクロによる処理に不要な動作設定を再開
labelEnd:
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

補足

あけましておめでとうございます。

作成することが出来ました。

質問させていただだきます、フォーマットのJ～L列に文字またはオートSUMが入力されているとエラーになってしまいます。

J列に表示される
.Value = Sheets(j).Name & "の" & SearchColumn(k) & "列～"
Case UBound(mySize)
.Value = .Value & SearchColumn(k) & "列の" & .Parent.Name & "の数量"

こちらをC列、もしくは表示させずにフォーマットのオートSUMや文字を残す方法をご教授いただけますでしょうか。

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

回答No.8

kagakusuki

回答No.4～7です。

>また、お手すきの際で結構ですのでこちらの点もご教授頂けますと幸いです。
>>No.1の補足コメントで申し上げました、フォーマットを一番右に置き、そのフォーマット>で各シートを作成することはできますでしょうか。

>フォーマットのD～Iの列7行目から順に入力したいと思っております。

　その場合は以下の様なVBAとなります。

Sub QNo9100653_Excel_VBA_シートの自動作成_データ_改3()

Const FirstRow = 4 '住所録が入力されているシートにおいて、最初の氏名が入力されている行の行番号
Const NameColumn0 = "B" '住所録が入力されているシートにおいて、氏名が入力されている列の列番号
Const NameColumn = "B" '住所録以外のシートにおいて、氏名が入力されている列の列番号
Const FirstSearchColumn = "C" 'カウントの対象となるシート上のサイズが入力されている列の中で最も左端にある列の列番号
Const SizeSetRepeatCount = 5 '最少～最大の各サイズが入力されている列の組が、1シート中に何組あるのかを指定する数値
Const FirstOutputColumn = "D" '各氏名と同名のシートにおいて、各サイズのカウント結果の数値を表示する列の中で最も左端にある列の列番号
Const FirstOutputRow = 7 '各氏名と同名のシートにおいて、各サイズのカウント結果の数値を表示する行の中で最も上にある行の行番号

Dim mySheetName(3) As String, msgOfSheet(3) As String, mySheet(3) As Worksheet, _
SearchColumn() As String, OutputColumn() As String, mySize As Variant, _
NameRange As Range, UnusableName As String, myOffset As Long, _
c As Range, i As Long, j As Long, k As Long

mySheetName(0) = "Sheet1" '住所録が入力されているシート
mySheetName(1) = "フォーマット" '各氏名と同名のシートを作成する際の雛型となるシート
mySheetName(2) = "Sheet2" 'カウントの対象となるシートの中で最も左端にあるシート
mySheetName(3) = "Sheet5" 'カウントの対象となるシートの中で最も右端にあるシート
msgOfSheet(0) = "住所録が入力されている"
msgOfSheet(1) = "各氏名と同名のシートを作成する際の雛型となる"
msgOfSheet(2) = "カウントの対象となるシートの中で最も左端にある"
msgOfSheet(3) = "カウントの対象となるシートの中で最も右端にある"
mySize = Array("SS", "S", "M", "L", "LL", "EL") 'サイズの名称の指定
ReDim SearchColumn((UBound(mySize) + 1) * SizeSetRepeatCount - 1)
i = 0
For Each c In Range(FirstSearchColumn & 1).Resize(1, UBound(SearchColumn) + 1)
SearchColumn(i) = c.Address(True, False)
SearchColumn(i) = Left(SearchColumn(i), InStr(SearchColumn(i), "$") - 1)
i = i + 1
Next c
ReDim OutputColumn((UBound(mySize) + 1))
i = 0
For Each c In Range(FirstOutputColumn & 1).Resize(1, UBound(OutputColumn) + 1)
i = (i + 1) Mod (UBound(OutputColumn) + 1)
OutputColumn(i) = c.Address(True, False)
OutputColumn(i) = Left(OutputColumn(i), InStr(OutputColumn(i), "$") - 1)
Next c

'シートの有無の確認
For i = 0 To 3
If IsError(Evaluate("ROW('" & mySheetName(i) & "'!A1)")) Then
MsgBox msgOfSheet(i) & "シートとして設定されている" _
& vbCrLf & vbCrLf & mySheetName(i) & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set mySheet(i) = Sheets(mySheetName(i))
Next i
For i = 0 To 1
With mySheet(i)
If .Index > mySheet(2).Index Then .Move Before:=mySheet(2)
End With
Next i

'マクロによる処理に不要な動作を停止
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

'住所録にある名前と同じシート名のシートを作成
Set NameRange = mySheet(0).Range(NameColumn0 & FirstRow & ":" _
& NameColumn0 & mySheet(0).Range(NameColumn0 & Rows.Count).End(xlUp).Row)
For Each c In NameRange
If c.Value <> "" Then
If IsError(Evaluate("ROW('" & c.Value & "'!A1)")) Then
mySheet(1).Copy After:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
On Error Resume Next
.Name = c.Value
On Error GoTo 0
If Sheets(Sheets.Count).Name = c.Value Then
.Range(OutputColumn(1) & FirstOutputRow & ":" & OutputColumn(0) & _
.Cells.SpecialCells(xlCellTypeLastCell).Row + 1).ClearContents
Else
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True
GoSub label1
End If
End With
Else
If Sheets(c.Value).Index <= mySheet(3).Index Then GoSub label1
End If
End If
Next c
If UnusableName <> "" Then _
MsgBox msgOfSheet(0) & "シートとして設定されている" _
& mySheetName(0) & "シートの" & NameColumn0 _
& "列に入力されている名前の内、以下のものは" _
& "シート名として使用する事が出来ない文字が含まれているか、" _
& "或いは既に他のシートのシート名として使用されている名称" _
& "であるため、新たなシート名として使用する事は出来ません。" _
& vbCrLf & "そのため下記の名前と同じシート名を持つシートは" _
& "作成する事ができませんでした。" & vbCrLf & UnusableName, _
vbExclamation, "無効なシート名"

※まだ途中なのですが、このサイトの回答欄には4000文字までしか入力する事が出来ませんので、残りは又後で投稿致します。

回答No.7

kagakusuki

回答No.6の続きです。

'住所録にある名前と同じシート名のシートを作成
Set NameRange = mySheet(0).Range(NameColumn0 & FirstRow & ":" _
& NameColumn0 & mySheet(0).Range(NameColumn0 & Rows.Count).End(xlUp).Row)
For Each c In NameRange
If c.Value <> "" Then
If IsError(Evaluate("ROW('" & c.Value & "'!A1)")) Then
On Error Resume Next
Sheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
On Error GoTo 0
If Sheets(Sheets.Count).Name <> c.Value Then
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True
GoSub label1
End If
Else
If Sheets(c.Value).Index <= mySheet(2).Index Then GoSub label1
End If
End If
Next c
If UnusableName <> "" Then _
MsgBox msgOfSheet(0) & "シートとして設定されている" _
& mySheetName(0) & "シートの" & NameColumn0 _
& "列に入力されている名前の内、以下のものは" _
& "シート名として使用する事が出来ない文字が含まれているか、" _
& "或いは既に他のシートのシート名として使用されている名称" _
& "であるため、新たなシート名として使用する事は出来ません。" _
& vbCrLf & "そのため下記の名前と同じシート名を持つシートは" _
& "作成する事ができませんでした。" & vbCrLf & UnusableName, _
vbExclamation, "無効なシート名"

'住所録にある名前と同じシート名のシート上に表を作成
For i = mySheet(2).Index + 1 To Sheets.Count
With Sheets(i)
.Range(OutputColumn(1) & ":" & OutputColumn(0)).Clear
If WorksheetFunction.CountIf(NameRange, .Name) > 0 Then
With .Range(OutputColumn(1) & FirstRow - 1)
With .Resize((mySheet(2).Index - mySheet(1).Index + 1) * _
SizeSetRepeatCount + 1, UBound(OutputColumn) + 1).Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Resize(1, UBound(mySize) + 1)
.Value = mySize
.HorizontalAlignment = xlCenter
End With
End With
For j = mySheet(1).Index To mySheet(2).Index
With .Range(OutputColumn(1) & Rows.Count).End(xlUp)
For k = 0 To UBound(SearchColumn)
myOffset = k Mod (UBound(mySize) + 1)
With .Offset(1 + Int(k / (UBound(mySize) + 1)))
With .Offset(, UBound(OutputColumn))
Select Case myOffset
Case 0
.Value = Sheets(j).Name & "の" & SearchColumn(k) & "列～"
Case UBound(mySize)
.Value = .Value & SearchColumn(k) & "列の" & .Parent.Name & "の数量"
End Select
End With
With .Offset(, myOffset)
.Value = .Value + WorksheetFunction.SumIf(Sheets(j).Columns(NameColumn), _
Sheets(i).Name, Sheets(j).Columns(SearchColumn(k)))
End With
End With
Next k
End With
Next j
End If
.Columns(OutputColumn(0)).AutoFit
End With
Next i

'label1をジャンプ
GoTo labelEnd

'住所録に入力されている氏名の中にシート名として使用できない文字列かあった場合の処理
label1:
With c.Font
.Strikethrough = True
.Color = 255
End With
c.Interior.Color = 65535
UnusableName = UnusableName & vbCrLf & c.Value
Return

'停止していたマクロによる処理に不要な動作設定を再開
labelEnd:
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

補足

kagakusuki 様

無事作成することができました。お付き合い頂き誠にありがとうございました。大変勉強になりました。

言葉足らずな部分まで補ってくださり、本当に助かりました。

また、お手すきの際で結構ですのでこちらの点もご教授頂けますと幸いです。
>No.1の補足コメントで申し上げました、フォーマットを一番右に置き、そのフォーマットで各シートを作成することはできますでしょうか。

フォーマットのD～Iの列7行目から順に入力したいと思っております。

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

回答No.6

kagakusuki

回答No.4、5です。

　情報を追加して頂き有難う御座います。

>コードを実行すると、指定した名前のアイテムが見つかりませんでした。と表示されます。

の件ですが、回答No.4のVBAは御質問の本文に

>Sheet 2～50までに同じフォーマットで
>A 　B　　C～E F～H
> No. 名前 S～L S～L

と書かれていたため、「S～Lの様なサイズが網羅された列のセット」が2セット(「C～E列」と「F～G列」の2組)存在している場合に対応させる様にしかしておらず、3セット以上存在している場合にまで対応させなければならなくなる様な事は想定しておりませんでした。
　ですから、

>「C～H」「I～N」この繰り返しが「AA～AF」まで

の様に、5セットも存在している場合に対応させようとしますと、エラーが発生します。

　それと、

> OutputColumn = Array("G", "D", "E", "F")
> "C～H"に変更

の所ですが、私が提案させて頂いたVBAの場合、配列変数OutputColumn(0)は「Sheet2AさんのC～E数量」などといった「どのシートのどの列のデータであるのかという事を示す文字列情報」を表示させるための列( "C～H"の右隣のI列)を指定する文字を格納するためのもので、 "C～H"はOutputColumn(1)以降に格納する様にしておりますので、 "C～H"の場合は、

> OutputColumn = Array("I", "C","D", "E", "F","G","H")

としなければなりません。

　それから、後になって気付いた事なのですが回答No.4のVBAでは、Sheet1のB列に入力されている名前の中に、シート名として使用する事が出来ない文字列が含まれていた場合、新たに作られるシート名が、(当然の事ながら)住所録の名前通りのシート名とはならず、例えば「Sheet51」などといった「シート名を指定せずに新たなシートを作成した場合のシート名」となってしまうというバグが御座いました。
　それと、住所録の名前の中に、Sheet1～50の間に存在しているシート名と同じ名前があった場合にも、同じ名前で新しいシートを作る事は出来ません。(こちらはバグではなく、エクセルの仕様上仕方がない事です)
　そこで、その様な「シート名として使用出来ない名前」が住所録上に存在した場合には、誤って作ってしまったSheet51等の新シートを削除した上で、Sheet1のB列に入力されている「シート名として使用出来ない名前」が取り消し線が引かれた赤文字表記となる様に改良したVBAを組みました。(住所録にある名前と同名のシートが、Sheet50よりも右側にある場合には、そのままそのシートがカウント結果の表示に使用されます)

　勿論、

>「C～H」「I～N」この繰り返しが「AA～AF」まで

やサイズが6種類に変更になった事にも対応させております。(但し、サイズの名称が不明なため、取り敢えず仮に"SS", "S", "M", "L", "LL", "EL"としております)
　この様に変更点が幾つもあるため、

>ここの部分を訂正すれば良いのでしょうか？

という御要望に応えて要修正個所だけを御伝えしたのでは、訳が解らなくなりそうですので、改良済みのVBAの構文の全文を回答させて頂きます。

Sub QNo9100653_Excel_VBA_シートの自動作成_データ_改2()

Const FirstRow = 4 '住所録が入力されているシートにおいて、最初の氏名が入力されている行の行番号
Const NameColumn0 = "B" '住所録が入力されているシートにおいて、氏名が入力されている列の列番号
Const NameColumn = "B" '住所録以外のシートにおいて、氏名が入力されている列の列番号
Const FirstSearchColumn = "C" 'カウントの対象となるシート上のサイズが入力されている列の中で最も左端にある列の列番号
Const SizeSetRepeatCount = 5 '最少～最大の各サイズが入力されている列の組が、1シート中に何組あるのかを指定する数値
Const FirstOutputColumn = "C" '各氏名と同名のシートにおいて、各サイズのカウント結果の数値を表示する列の中で最も左端にある列の列番号

Dim mySheetName(2) As String, msgOfSheet(2) As String, mySheet(2) As Worksheet, _
SearchColumn() As String, OutputColumn() As String, mySize As Variant, _
NameRange As Range, UnusableName As String, myOffset As Long, _
c As Range, i As Long, j As Long, k As Long

mySheetName(0) = "Sheet1" '住所録が入力されているシート
mySheetName(1) = "Sheet2" 'カウントの対象となるシートの中で最も左端にあるシート
mySheetName(2) = "Sheet5" 'カウントの対象となるシートの中で最も右端にあるシート
msgOfSheet(0) = "住所録が入力されている"
msgOfSheet(1) = "カウントの対象となるシートの中で最も左端にある"
msgOfSheet(2) = "カウントの対象となるシートの中で最も右端にある"
mySize = Array("SS", "S", "M", "L", "LL", "EL") 'サイズの名称の指定
ReDim SearchColumn((UBound(mySize) + 1) * SizeSetRepeatCount - 1)
i = 0
For Each c In Range(FirstSearchColumn & 1).Resize(1, UBound(SearchColumn) + 1)
SearchColumn(i) = c.Address(True, False)
SearchColumn(i) = Left(SearchColumn(i), InStr(SearchColumn(i), "$") - 1)
i = i + 1
Next c
ReDim OutputColumn((UBound(mySize) + 1))
i = 0
For Each c In Range(FirstOutputColumn & 1).Resize(1, UBound(OutputColumn) + 1)
i = (i + 1) Mod (UBound(OutputColumn) + 1)
OutputColumn(i) = c.Address(True, False)
OutputColumn(i) = Left(OutputColumn(i), InStr(OutputColumn(i), "$") - 1)
Next c

'シートの有無の確認
For i = 0 To 2
If IsError(Evaluate("ROW('" & mySheetName(i) & "'!A1)")) Then
MsgBox msgOfSheet(i) & "シートとして設定されている" _
& vbCrLf & vbCrLf & mySheetName(i) & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set mySheet(i) = Sheets(mySheetName(i))
Next i

'マクロによる処理に不要な動作を停止
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

※まだ途中なのですが、このサイトの回答欄には4000文字までしか入力する事が出来ませんので、残りは又後で投稿致します。

回答No.5

kagakusuki

回答No.4です。

>コードを実行すると、指定した名前のアイテムが見つかりませんでした。と表示されます。

　それだけではどの様な状況になっているのかさっぱり解りませんので、答え様が御座いません。
　前回の投稿前に当方でマクロ有効ファイルを試作して、回答No.4のマクロを実際に試した際にはその様な現象は現れませんでした。(流石にシートを51枚以上も作った訳ではありませんが)
　ですから、おそらく当方が組んだVBAを質問者様が変更したか、或いは、

>Sheet 1 に住所録
>Sheet 2～50までに同じフォーマットで
>A 　B　　C～E F～H
>No. 名前 S～L S～L

>と並んでいてA4から名前　C～の列には各数量が50行ほど入力されています。

>Sheet1とSheet2～50の名前順は同じです。

という条件のどこかに、実際の条件とは異なる点があるためではないかと思われます。
　ですので、もし質問者様が回答No.4のVBAから変更した点がある場合には、どこをどの様に変更したのかという事を、詳細に御教え願います。
　又、Sheet 2～50に関しても、本当にSheet2が左端(Sheet1の右隣)で、Sheet50が右端にあるのかという事や、
C列とF列が「Sの数量」、
D列とG列が「Mの数量」、
E列とH列が「Lの数量」
となっていて、列が3列1組となっているのかという事、mySheetName(0) 、mySheetName(1) 、mySheetName(2)に設定したシート名が入れ替わっていないかという事、等を御教え願います。
　又、現れたエラーの警告内容の、エラーコードの番号も含む全文と、そのエラーが出た際にVBAの構文の中のどの行が黄色で塗り潰されていたのかという事も御教え願います。
　もしかしますと、塗り潰されていたのは

.Value = Sheets(j).Name & "の" & SearchColumn(k) & "列～"
Case Linefeed - 1, UBound(SearchColumn)
.Value = .Value & SearchColumn(k) & "列の数量"

の3行の内のどれかなのでしょうか？
　それでも3行のうちのどれが塗り潰されていたのかが判りません。

補足

kagakusuki 様

ご返信ありがとうございます。No.2の方もおっしゃいますように、質問内容に不備があり誠に申し訳ありません。反省しております。

私が修正した点を申し上げます。

Sub QNo9100653_Excel_VBA_シートの自動作成_データ()

Const FirstRow = 4 'Sheet1において、最初の氏名が入力されている行の行番号　"2"に変更しました。
Const Linefeed = 3 '「C～E」と「F～H」の区別をつけるための数(C～E列に含まれる列数)
実際のところは"6"でしたので変更しました。(「C～H」「I～N」この繰り返しが「AA～AF」まで)

mySheetName(0) = "Sheet1" '住所録が入力されているシート
mySheetName(1) = "Sheet2" 'カウントの対象となるシートの中で最も左端にあるシート
mySheetName(2) = "Sheet50" 'カウントの対象となるシートの中で最も右端にあるシート

各シート名を変更しました。

SearchColumn = Array("C", "D", "E", "F", "G", "H")
こちらも"AF"まで
OutputColumn = Array("G", "D", "E", "F")
"C～H"に変更
mySize = Array("S", "M", "L")
該当するsizeに変更しました。

.Resize(1, 6).Value = mySize
With .Offset(, 6)

変更しました。

kagakusuki 様のVBAに合うように作りと試しにVBAを実行したところ機能したのですが、

エラー警告内容は
microsoft visual basic 指定した名前のアイテムが見つかりませんでした。
黄色で塗りつぶされず、OKの表示のみです。

Excel:Mac2011 を使用しています。

No.1の補足コメントで申し上げました、フォーマットを一番右に置き、そのフォーマットで各シートを作成することはできますでしょうか。

大変お恥ずかしい限りですが、どうぞよろしくお願い致します。

回答No.4

kagakusuki

以下の様なマクロは如何でしょうか。

Sub QNo9100653_Excel_VBA_シートの自動作成_データ()

Const FirstRow = 4 'Sheet1において、最初の氏名が入力されている行の行番号
Const NameColumn0 = "B" 'Sheet1において、氏名が入力されている列の列番号
Const NameColumn = "B" 'Sheet1以外のシートにおいて、氏名が入力されている列の列番号
Const Linefeed = 3 '「C～E」と「F～H」の区別をつけるための数(C～E列に含まれる列数)
Dim mySheetName(2) As String, msgOfSheet(2) As String, mySheet(2) As Worksheet, _
SearchColumn As Variant, OutputColumn As Variant, mySize As Variant, _
NameRange As Range, temp As Variant, c As Range, i As Long, j As Long, k As Long

mySheetName(0) = "Sheet1" '住所録が入力されているシート
mySheetName(1) = "Sheet2" 'カウントの対象となるシートの中で最も左端にあるシート
mySheetName(2) = "Sheet50" 'カウントの対象となるシートの中で最も右端にあるシート
msgOfSheet(0) = "住所録が入力されている"
msgOfSheet(1) = "カウントの対象となるシートの中で最も左端にある"
msgOfSheet(2) = "カウントの対象となるシートの中で最も右端にある"
SearchColumn = Array("C", "D", "E", "F", "G", "H")
OutputColumn = Array("G", "D", "E", "F")
mySize = Array("S", "M", "L")

For i = 0 To 2
If IsError(Evaluate("ROW('" & mySheetName(i) & "'!A1)")) Then
MsgBox "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & mySheetName(i) & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set mySheet(i) = Sheets(mySheetName(i))
Next i

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

Set NameRange = mySheet(0).Range(NameColumn0 & FirstRow & ":" _
& NameColumn0 & mySheet(0).Range(NameColumn0 & Rows.Count).End(xlUp).Row)

For Each c In NameRange
If c.Value <> "" Then
If IsError(Evaluate("ROW('" & c.Value & "'!A1)")) Then
On Error Resume Next
Sheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
On Error GoTo 0
End If
End If
Next c

For i = mySheet(2).Index + 1 To Sheets.Count
With Sheets(i)
.Range(OutputColumn(1) & ":" & OutputColumn(0)).Clear
With .Range(OutputColumn(1) & FirstRow - 1)
With .Resize((mySheet(2).Index - mySheet(1).Index) * 2 + 3, 4).Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
.Resize(1, 3).Value = mySize
End With
For j = mySheet(1).Index To mySheet(2).Index
With .Range(OutputColumn(1) & Rows.Count).End(xlUp)
For k = 0 To UBound(SearchColumn)
With .Offset(1 - (k >= Linefeed))
With .Offset(, 3)
Select Case k
Case 0, Linefeed
.Value = Sheets(j).Name & "の" & SearchColumn(k) & "列～"
Case Linefeed - 1, UBound(SearchColumn)
.Value = .Value & SearchColumn(k) & "列の数量"
End Select
End With
With .Offset(, k Mod Linefeed)
.Value = .Value + WorksheetFunction.SumIf(Sheets(j).Columns(NameColumn), _
Sheets(i).Name, Sheets(j).Columns(SearchColumn(k)))
End With
End With
Next k
End With
Next j
End With
Next i

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

補足

kagakusuki 様

ご丁寧な回答、有り難うございます。

とても分かりやすく解説していただいたのにも関わらず、恥を忍んで質問させていただきたく存じます。

コードを実行すると、指定した名前のアイテムが見つかりませんでした。と表示されます。
.Value = Sheets(j).Name & "の" & SearchColumn(k) & "列～"
Case Linefeed - 1, UBound(SearchColumn)
.Value = .Value & SearchColumn(k) & "列の数量"

ここの部分を訂正すれば良いのでしょうか？
よろしくお願い致します。

回答No.3

imogasi

#2です。エクセル操作に「統合」というのがあります。ご存じですか。
ＶＢＡの初歩ができると、ほとんど何でも繰り返しの作業コードで、出来てしまいまいます。それに頼りがちになります。
だからレパートリーを広げる勉強をしないと、進歩が止まります。特にピヴォットテーブル
などはそれでしょう。
質問の表現の仕方、例の挙げ方も含めて、下記は私の経験から割り出した方法です。
参考にしてください。
この集約表ができても、質問で言っている、望む最終表ではないでしょうが、その後の目的の表をＶＢＡで作成するのは、極く簡単になるでしょう。
ーー
例データ　Ａ－Ｄ列　下記表の数字は獲得点数と見てください。
「第１学期」　シート
氏名 国語 算数 合計
田中 23 78 101
山本 45 48 93
高橋 65 49 114
小林 52 65 117
中村 88 59 147
ーー
第２学期　シート　Ａ－Ｄ列
氏名 国語 算数 合計
田中 35 84 119
山本 56 65 121
高橋 72 68 140
小林 81 66 147
中村 39 54 93
ーー
第３学期　シート　Ａ－Ｄ列
氏名 国語 算数 合計
高橋 63 26 89
山本 50 73 123
田中 49 37 86
小林 39 66 105
中村 83 61 144
集計　シート　Ａ－Ｄ列
見出しだけ、作業前に作成しておく（他シートのコピーでできる）
氏名　国語　算数 合計
田中
山本
高橋
小林
中村
氏名の出現順は最終的に、利用に都合のよい並びで可。
データのある３つのシート表の第１列の氏名の並びも、各シートで乱れていても可。
ここが「統合」の素晴らしいところ。
ーー
ＶＢＡコード
Sub 統合1()
With Worksheets("集計")
.Range("A:C").ClearContents
'Ｂ２－Ｄ１００
.Range("A1").Consolidate _
Sources:=Array("1学期!R1C1:R100C4", _
"2学期!R1C1:R100C4", _
"3学期!R1C1:R100C4"), _
Function:=xlSum, _
TopRow:=True, LeftColumn:=True, _
CreateLinks:=False
End With
End Sub
範囲は「Ｒ１Ｃ１形式」で記述する。
（ＶＢＡで実行）結果
「集計」シートは
国語 算数 合計
田中 107 199 306
山本 151 186 337
高橋 200 143 343
小林 172 197 369
中村 210 174 384
質問での、Ｃ－Ｅ列やF～G列の合計を作っておけば後の処理がしやすいだろう。

補足

imogasi 様

質問の方法等、大変参考になりました。
有り難う御座います。

とても勉強になりました。

回答No.2

imogasi

もう回答は１件出ているが、質問の書き方が質問者の独断的でよくわからない。
・Ｓｈｅｅｔ１の名前の名簿は、結果においてどういう使い方をするのか。
・人ごとに別（集計？）シートを別シートとして作るのか。
＞同じフォーマットで
といっても、名前の（たとえばＡさんの）データの出てくる行は各シートで決まってない（バラバラない）のか。
シート２~シート５０の各列に入っているデータは同じ性格の範疇のものだろうね。
あるいは時期別に捉えた金額のように同室のものか。
・C～E F～HはＣ，Ｄ、Ｆ列とＦ，Ｇ，Ｈの列のことだと思うが２つに分けて記述している意味は？
・Sheet1とSheet2～50の名前順は同じです。
とは、シート１の行的に出現する名前とＳｈｅｅｔ２からＳｈｅｅｔ５０のシート名のい見た目の順序は同じにするということか。
・DEF列　SML　のＳＭＬは何ですか？
・1行目1,2,3(Sheet2AさんのC～E数量)
もし数量＝数値データなら１，２，３などでなく２桁ぐらいの数字を例にする方がわかりやすいのではないか。
１２３とは何の番号？次の2行目2,2,2とは何？数量数字か？Ｓｈｅｅｔ５２
・同じようにSheet 53　Bさん
ということはＳｈｅｅｔ５２はどうなる？飛ばすのか。Ａさんの集約データを２シートで作るのか。
＝＝＝
文章でも十分徹底しない、データ例がよくわからない、書き方をするより、データ数（人数＝名前を３－５人ぐらいにして）模擬実例（シート面らしい、行と列の２次元のもの）を書いて、列も３列ぐらいにして、数量も３行ぐらいにして、例を挙げてはどうか？
ー
回答のコードから、拡張や修正するのは、回答を見ての質問者の仕事だろう。回答者に面倒をできるだけ、かけないようにしてほしい。
・串刺し演算的なことはこの課題では使えるのか？
＞自動で作成したいです
自動というよりも、ＶＢＡコードを作り実行して、だろう。
関数のような自動とは意味が違うだろう。
ーー
＃１で正解なら問題は解決なんだが、今後の質問において要望しておきたい。