投稿日:

【Excel】インクリメントしたシート名を追加する

Sub Test()
Dim resultSheetName As String: resultSheetName = "テスト結果" '基本となるシート名
Dim newSheetName As String: newSheetName = resultSheetName '動的に変化するシート名
Dim count As Integer: count = 1

Dim ws As Worksheet
'全てのシートを走査し、同じシート名が存在する場合はcountを加算してnewSheetNameを更新
For Each ws In Worksheets
If ws.Name = newSheetName Then
count = count + 1
newSheetName = resultSheetName & "(" & CStr(count) & ")"
End If
Next ws

'シート追加及び名称変更
Dim newWorksheet As Worksheet: Set newWorksheet _
= Worksheets.Add(After:=Sheets(Worksheets.count))
newWorksheet.Name = newSheetName

'Testシートに戻る
Sheets("Test").Select
End Sub
投稿日:

【Excel】指定した数だけデータをコピーする

①コピー元シートを用意
※ここでは「表を複数の条件で絞り込む②」で作成したシートを使用(数量列だけ追加)

②ペーストするシートを用意

③コピーを実行するボタンを配置

④ボタン配置時の以下の画面で「マクロ名」を「CreateLabelData」として「新規作成」を押す

⑤「Microsoft Visual Basic for Applications」にて以下のコードを記載
※表の形式に応じて「★」のついた箇所の数値を変更

Sub CreateLabelData()
'コピー開始行
Dim copyStartRow As Integer: copyStartRow = 5 '★
'コピー最終行
Dim copyLastRow As Integer: copyLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
'コピー開始列
Dim copyStartCol As Integer: copyStartCol = 2 '★
'コピー終了列
Dim copyLastCol As Integer: copyLastCol = 4 '★
'数量列
Dim quantityCol As Integer: quantityCol = 5 '★

'ペーストするシート名
Dim pasteSheetName As String: pasteSheetName = "商品ラベルデータ" '★
'ペースト行
Dim pasteRow As Integer: pasteRow = 2 '★
'ペースト列
Dim pasteCol As Integer: pasteCol = 1 '★
'ペーストするシートの最終行
pasteLastRow = Worksheets(pasteSheetName).UsedRange.Row + Worksheets(pasteSheetName).UsedRange.Rows.Count - 1

'ペーストするシートの初期化
For i = pasteRow To pasteLastRow Step 1
Worksheets(pasteSheetName).Rows(pasteRow).Delete
Next

'コピー開始行から終了行までループ
For i = copyStartRow To copyLastRow Step 1
'数量の指定が不正な場合は次の行へ
If Cells(i, quantityCol).Formula = "" Or IsNumeric(Cells(i, quantityCol).Value) = False Or Cells(i, quantityCol).Value < 1 Then
GoTo Continue
Else
End If

'対象行の数量を取得
Dim quantity As Integer: quantity = Cells(i, quantityCol).Value

'数量分コピー&ペーストを行う
For j = pasteRow To pasteRow + quantity - 1 Step 1
Range(Cells(i, copyStartCol), Cells(i, copyLastCol)).Copy Destination:=Worksheets(pasteSheetName).Cells(j, pasteCol)
Next

'次回ペースト行の更新
pasteRow = pasteRow + quantity

'数量の値を初期化
Cells(i, quantityCol).Value = ""
Continue:
Next

'ペーストしたシートを選択
Worksheets(pasteSheetName).Select
Worksheets(pasteSheetName).Cells(1, 1).Select
End Sub
投稿日:

【Excel】各シートの値を集計する

①マクロを使えるようにする
「マクロを使えるようにする」を参照

②集計表のタイトルを用意

③集計するシートを用意

④集計用ボタンを配置

⑤ボタン配置時の以下の画面で「マクロ名」を「Aggregate」として「新規作成」を押す

⑥「Microsoft Visual Basic for Applications」にて以下のコードを記載
※★の部分を作成するレイアウトに合わせて修正

Sub Aggregate()
Dim sheet As Worksheet
'「集計」シートのシート名
Dim aggregateSheetName As String: aggregateSheetName = "集計" '★
'「集計」シートで大学名を表示する列
Dim collegeNameCol As Integer: collegeNameCol = 2 '★
'開始行
Dim startRow As Integer: startRow = 3 '★
'最終行
Dim lastRow As Integer: lastRow = Sheets(aggregateSheetName).Cells(Rows.Count, collegeNameCol).End(xlUp).Row + 1
'各シートで大学名が記載されたCell
Dim collegeNameCell As String: collegeNameCell = "A4" '★

'一旦行をすべてクリア
For i = startRow To lastRow - 1 Step 1
Rows(3).Delete
Next

'全てのシート分繰り返し処理
For Each sheet In Sheets
'「集計」シートの場合は何もしないで次のシートへ
If sheet.Name = aggregateSheetName Then
GoTo CONTINUE
End If

'最終行の再取得
lastRow = Sheets(aggregateSheetName).Cells(Rows.Count, collegeNameCol).End(xlUp).Row + 1

'各シートの大学名が記載されたCellの値を取得
Dim collegeName As String: collegeName = sheet.Range(collegeNameCell).Value

'「集計」シートのB列を３行目から最終行まで走査
For i = startRow To lastRow - 1 Step 1
'一致する行がある場合はC列に１を加算
If Cells(i, collegeNameCol).Value = collegeName Then
Cells(i, collegeNameCol + 1).Value = Cells(i, collegeNameCol + 1).Value + 1
'次のシートへ
GoTo CONTINUE
End If
Next

'最終行まで一致する行がなかった場合
If i = lastRow Then
'最終行のB列に大学名を代入
Cells(i, collegeNameCol).Value = collegeName
'C列に１を加算
Cells(i, collegeNameCol + 1).Value = Cells(i, collegeNameCol + 1).Value + 1
'罫線を引く
Cells(i, collegeNameCol).Borders.LineStyle = xlContinuous
Cells(i, collegeNameCol + 1).Borders.LineStyle = xlContinuous
End If
CONTINUE:
Next
End Sub

⑦「集計」ボタンを押すと各シートの値が集計される