月: 2024年12月

★指定したフォルダ内のブックにおいて、現在開いているアクティブシートのA列にまとめたい新規のブック名（拡張子付き）を登録、Ｂ列にそのブックにもっていきたい（そのフォルダ内の）ブック名（拡張子付き）を登録しておく★

Sub 指定ブックをシートに登録()
Dim folderPath As String
Dim fileName As String
Dim sheetName As String
Dim targetWorkbook As Workbook
Dim sourceWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim cell As Range
Dim ws As Worksheet
Dim totalFiles As Long
Dim processedFiles As Long

' フォルダのパスを入力
folderPath = InputBox("操作対象になるフォルダのパスを入力してください", "フォルダの選択")
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

' 画面の更新を停止
Application.ScreenUpdating = False

' 処理対象のファイル数をカウント
totalFiles = ActiveSheet.Range("A1:A" & ActiveSheet.Cells(rows.Count, 1).End(xlUp).row).Count
processedFiles = 0

' A列の各セルをループ
For Each cell In ActiveSheet.Range("A1:A" & ActiveSheet.Cells(rows.Count, 1).End(xlUp).row)
    fileName = cell.Value
    sheetName = Left(cell.Offset(0, 1).Value, InStrRev(cell.Offset(0, 1).Value, ".") - 1)

    ' ターゲットブックが存在するか確認し、存在しなければ作成
    On Error Resume Next
    Set targetWorkbook = Workbooks.Open(folderPath & fileName)
    If Err.Number <> 0 Then
        Set targetWorkbook = Workbooks.Add
        targetWorkbook.SaveAs folderPath & fileName
    End If
    On Error GoTo 0

    ' ソースブックを開く
    Set sourceWorkbook = Workbooks.Open(folderPath & cell.Offset(0, 1).Value)

    ' ソースブックに複数シートがある場合はエラーを表示して停止
    If sourceWorkbook.Sheets.Count > 1 Then
        MsgBox "エラー: " & sourceWorkbook.Name & " に複数のシートがあります。処理を中止します。"
        sourceWorkbook.Close False
        targetWorkbook.Close False
        Exit Sub
    End If

    Set sourceSheet = sourceWorkbook.Sheets(1)

    ' ソースシートをターゲットブックにコピー
    sourceSheet.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
    targetWorkbook.Sheets(targetWorkbook.Sheets.Count).Name = sheetName

    ' ソースブックを保存せずに閉じる
    sourceWorkbook.Close False

    ' 空白のシートを削除
    For Each ws In targetWorkbook.Sheets
        If WorksheetFunction.CountA(ws.Cells) = 0 Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next ws

    ' 各シートを100%表示にし、A1セルにフォーカスを当てる
    For Each ws In targetWorkbook.Sheets
        ws.Activate
        ActiveWindow.Zoom = 100
        ws.Cells(1, 1).Select
    Next ws

    ' 一番左のシートをアクティブにする
    targetWorkbook.Sheets(1).Activate

    ' ターゲットブックを保存して閉じる
    targetWorkbook.Close True

    ' 進捗状況を更新
    processedFiles = processedFiles + 1
    Application.StatusBar = "進捗: " & Format(processedFiles / totalFiles, "0%") & " 完了"
Next cell

' 画面の更新を再開
Application.ScreenUpdating = True
Application.StatusBar = False

MsgBox "シートの登録が完了しました！"

End Sub

Sub テキストボックス作成()
Dim originalShape As shape
Dim newShape As shape
Dim i As Integer, j As Integer
Dim horizontalSpacing As Single
Dim verticalSpacing As Single
Dim columns As Integer
Dim shapeCounts As Variant
Dim currentShape As Integer
Dim shapeIndex As Integer
Dim currentRow As Integer
Dim currentColumn As Integer

' 列の数を入力するためのInputBoxを表示
columns = InputBox("何列にしますか？（区切る数より多く）", "列の設定", 3)
' 作る個数をスペースで区切って入力するためのInputBoxを表示
shapeCounts = Split(InputBox("作る個数をスペースで区切って入力してください（例：5 3 3 3 3 3）", "個数の設定", "5 3 3 3 3 3"))

' 新しいテキストボックスを作成
Set originalShape = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 4.52 * 28.35, 1.71 * 28.35) ' cmをポイントに変換
With originalShape.TextFrame.Characters.Font
    .Name = "Meiryo UI"
    .Size = 11 ' 任意の初期サイズ
End With
' 塗りつぶしなし、線の色は黒、線の太さは0.75に設定
With originalShape.line
    .ForeColor.RGB = RGB(0, 0, 0)
    .Weight = 0.75
End With
originalShape.Fill.Transparency = 1

' 間隔の設定
horizontalSpacing = 10
verticalSpacing = 20

' 指定された個数で複製
currentShape = 1
currentRow = 0
currentColumn = 0
For shapeIndex = 0 To UBound(shapeCounts)
    For i = 1 To CInt(shapeCounts(shapeIndex))
        If currentShape > 1 Then
            ' 複製を作成
            Set newShape = originalShape.Duplicate
            ' 新しい位置を設定
            newShape.Left = originalShape.Left + (originalShape.Width + horizontalSpacing) * currentColumn
            newShape.Top = originalShape.Top + (originalShape.Height + verticalSpacing) * currentRow
            ' デフォルトのフォントを設定
            With newShape.TextFrame.Characters.Font
                .Name = "Meiryo UI"
                .Size = 11 ' 任意の初期サイズ
            End With
            ' 塗りつぶしなし、線の色は黒、線の太さは0.75に設定
            With newShape.line
                .ForeColor.RGB = RGB(0, 0, 0)
                .Weight = 0.75
            End With
            newShape.Fill.Transparency = 1
        End If
        currentShape = currentShape + 1
        currentColumn = currentColumn + 1
        If currentColumn >= columns Then
            currentColumn = 0
            currentRow = currentRow + 1
        End If
    Next i
    currentRow = currentRow + 1 ' 各塊の間に1行空ける
    currentColumn = 0
Next shapeIndex

End Sub

Sub テキストボックスに書き込み()
Dim shp As shape
Dim i As Integer
Dim lastRow As Long
Dim firstLine As String
Dim secondLine As String
Dim pos As Long
Dim ws As Worksheet
Dim activeWs As Worksheet

' シート「WORK」を設定
Set ws = Worksheets("WORK")
' アクティブシートを設定
Set activeWs = ActiveSheet

' シート「WORK」内の最後の行を取得
lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row

' 空のテキストボックスに値を埋める
i = 1
For Each shp In activeWs.Shapes
    If shp.Type = msoTextBox Then
        If shp.TextFrame.Characters.text = "" Then
            If i <= lastRow Then
                ' 1行目と2行目の内容を設定
                firstLine = ws.Cells(i, "E").Value
                secondLine = ws.Cells(i, "F").Value
                shp.TextFrame.Characters.text = firstLine & vbCrLf & secondLine

                ' 1行目のフォント設定
                With shp.TextFrame.Characters(1, Len(firstLine)).Font
                    .Name = "Meiryo UI"
                    .Size = 11
                End With

                ' 2行目のフォント設定
                pos = Len(firstLine) + 2 ' 2行目の開始位置を設定
                With shp.TextFrame.Characters(pos, Len(secondLine)).Font
                    .Name = "Meiryo UI"
                    .Size = 8
                End With

                ' テキストを中央揃えに設定
                shp.TextFrame.HorizontalAlignment = xlHAlignCenter

                i = i + 1
            Else
                Exit For
            End If
        End If
    End If
Next shp

End Sub