VBAテスト

三角波比較

```
Function CompareWaves(sineWave As Double, triangleWave As Double) As Integer
    If sineWave > triangleWave Then
        CompareWaves = 1
    Else
        CompareWaves = -1
    End If
End Function
```

キャリア
```
Function TriangleWave(degree As Double) As Double
    Dim normalizedDegree As Double
    normalizedDegree = degree Mod 360

    If normalizedDegree < 180 Then
        TriangleWave = 1 - 2 * (normalizedDegree / 180)
    Else
        TriangleWave = -1 + 2 * ((normalizedDegree - 180) / 180)
    End If
End Function
```


パワーポイント貼り付け
```
Sub ImportPowerPointSlides()

    Dim pptApp As Object
    Dim pptPresentation As Object
    Dim pptSlide As Object
    Dim excelWs As Worksheet
    Dim slidePath As String
    Dim i As Integer
    Dim nextTop As Double

    ' PowerPoint アプリケーションを開く (既に開いている場合はそれを利用)
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

    If pptApp Is Nothing Then
        Set pptApp = CreateObject("PowerPoint.Application")
    End If

    ' ファイルダイアログを使用してPowerPointファイルのパスを選択
    slidePath = Application.GetOpenFilename("PowerPointファイル(*.pptx; *.ppt), *.pptx; *.ppt")

    ' キャンセルがクリックされた場合は終了
    If slidePath = "False" Then Exit Sub

    ' PowerPoint プレゼンテーションを開く
    Set pptPresentation = pptApp.Presentations.Open(slidePath)

    ' アクティブなExcelワークシートを取得
    Set excelWs = ThisWorkbook.ActiveSheet

    ' 初期のトップ位置を設定
    nextTop = excelWs.Cells(1, 1).Top

    For i = 1 To pptPresentation.Slides.Count
        Set pptSlide = pptPresentation.Slides(i)

        ' スライドを一時的なフォルダに画像としてエクスポート
        pptSlide.Export Environ("TEMP") & "\tempSlide.jpg", "JPG"

        ' Excelに画像を貼り付け
        With excelWs.Pictures.Insert(Environ("TEMP") & "\tempSlide.jpg")
            .Left = excelWs.Cells(1, 1).Left
            .Top = nextTop
            ' 次の画像の開始位置を更新
            nextTop = nextTop + .Height
        End With
    Next i

    ' PowerPoint プレゼンテーションを閉じる
    pptPresentation.Close

    ' 参照をクリア
    Set pptSlide = Nothing
    Set pptPresentation = Nothing
    Set pptApp = Nothing

    MsgBox "完了しました!", vbInformation

End Sub
```


リンク
```

Sub CreateTabAndLink()

    Dim selectedCell As Range
    Dim currentWs As Worksheet
    Dim newWs As Worksheet
    Dim wsName As String

    ' 現在のワークシートと選択されているセルを取得
    Set currentWs = ActiveSheet
    Set selectedCell = ActiveCell

    ' セルの値を新しいワークシートの名前として使用する
    wsName = selectedCell.Value

    ' 新しいワークシートを作成
    Set newWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))

    ' 新しいワークシートの名前を変更
    newWs.Name = wsName

    ' 新しいワークシートのA1セルに「戻る」というテキストを入力
    newWs.Range("A1").Value = "戻る"

    ' 新しいワークシートのA1セルに元のシートへのリンクを追加
    newWs.Hyperlinks.Add _
        Anchor:=newWs.Range("A1"), _
        Address:="", _
        SubAddress:="'" & currentWs.Name & "'!" & selectedCell.Address, _
        TextToDisplay:="戻る"

    ' 選択されたセルに新しいワークシートへのリンクを追加
    selectedCell.Hyperlinks.Add _
        Anchor:=selectedCell, _
        Address:="", _
        SubAddress:="'" & wsName & "'!A1", _
        TextToDisplay:=wsName

End Sub
```





バスバー
```
Function Inductance(l As Double, h As Double, w As Double, ur As Double) As Double
    Const pi As Double = 3.14159265358979
    Const u0 As Double = 4 * pi * 10 ^ -7

    ' Calculate the inductance
    Inductance = 2 * u0 * ur * l / pi * Log(1 + h / (h + w))
End Function
```


Zip自動解答
```
Sub SaveSelectedEmailAttachments()
    Dim sourceExtension As String
    Dim destinationFolder As String
    Dim email As MailItem
    Dim attachments As Attachments
    Dim attachment As attachment
    Dim senderEmail As String
    Dim receivedDate As String
    Dim newName As String
    Dim destinationPath As String
    Dim tempPath As String
    Dim objShell As Object
    
    ' 拡張子と保存先フォルダを設定
    sourceExtension = ".zi"
    destinationFolder = "C:\Temp"

    ' 現在選択されているメールを取得
    On Error Resume Next
    Set email = Application.ActiveExplorer.Selection.Item(1)
    On Error GoTo 0
    
    If Not email Is Nothing Then
        Set attachments = email.Attachments
        senderEmail = email.SenderEmailAddress
        receivedDate = Format(email.ReceivedTime, "yyMMdd_HHmm")
        
        ' 添付ファイルを処理
        For i = 1 To attachments.Count
            Set attachment = attachments.Item(i)
            If Right(attachment.FileName, Len(sourceExtension)) = sourceExtension Then
                ' 添付ファイルの名前と保存先を設定
                newName = Left(senderEmail, 5) & "_" & receivedDate & ".zip"
                destinationPath = destinationFolder & "\" & newName
                
                ' 一時的なパスに添付ファイルを保存
                tempPath = destinationFolder & "\" & attachment.FileName
                attachment.SaveAsFile tempPath

                ' 添付ファイルの拡張子を変更して保存先フォルダに移動
                Name tempPath As destinationPath

                ' C:\Tempフォルダを開いて、一番前のウィンドウに持ってくる
                Dim folderPath As String
                folderPath = "C:\Temp"
                Shell "explorer.exe """ & folderPath & """", vbNormalFocus

            End If
        Next i
    Else
        MsgBox "メールが選択されていません。"
    End If
End Sub
```



修正版　UpdateStateus
```
' この関数は、与えられたprogress（進捗率）とdueDate（期日）の値に応じて、タスクのステータスを返します。
Function UpdateStatus(progress As Variant, dueDate As Variant) As String
    ' progressとdueDateの両方が空の場合
    If IsEmpty(progress) And IsEmpty(dueDate) Then
        UpdateStatus = ""
    ' dueDateが今日の日付より前の場合
    ElseIf dueDate < Date Then
        UpdateStatus = "予定超過"
    ' progressが空の場合
    ElseIf IsEmpty(progress) Then
        UpdateStatus = "未着手"
    ' progressが100の場合
    ElseIf progress = 100 Then
        UpdateStatus = "完了"
    ' progressが0以上50未満で、期日が5日以内の場合
    ElseIf progress >= 0 And progress < 50 And (dueDate - Date) <= 5 And (dueDate - Date) >= 0 Then
        UpdateStatus = "実施判断"
    ' progressが0以上100未満の場合
    ElseIf progress >= 0 And progress < 100 Then
        UpdateStatus = "進行中"
    ' それ以外の場合
    Else
        UpdateStatus = "保留"
    End If
End Function


```


コラムコピー


```vba:vba
Sub CopyDColumn()
    Dim ws As Worksheet
    Dim srcRow As Range
    Dim newRow As Range
    
    Set ws = ActiveSheet
    Set srcRow = ws.Range("D" & ActiveCell.Row)
    Set newRow = ws.Rows(ActiveCell.Row + 1)
    
    Application.ScreenUpdating = False
    
    ' 挿入先の行を1行下に移動
    newRow.Insert Shift:=xlDown
    
    ' コピー＆ペースト
    srcRow.Copy Destination:=newRow.Cells(1, "D")
    
    ' 挿入した行の他のセルの内容を削除
    newRow.Cells(1, "A").Resize(, 3).ClearContents
    newRow.Cells(1, "E").Resize(, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column - 4).ClearContents
    
    Application.ScreenUpdating = True
End Sub

```


大項目追加ボタン
```　 
' このサブルーチンは、アクティブな行をコピーし、その直下に挿入します。
' ただし、1から4行目で実行された場合は何も実行されません。
' コピーされた新しい行では、D列とJ列以外のセルの内容がクリアされます（GZ列まで）。
Sub CopyActiveRow()
    Dim ws As Worksheet
    Dim srcRow As Range
    Dim newRow As Range
    Dim dstRow As Range
    
    ' アクティブセルが1から4行目にある場合、何も実行しない
    If ActiveCell.Row >= 1 And ActiveCell.Row <= 4 Then Exit Sub
    
    Set ws = ActiveSheet
    Set srcRow = ws.Rows(ActiveCell.Row)
    
    Application.ScreenUpdating = False
    
    ' 挿入先の行を1行下に移動
    srcRow.Offset(1, 0).Insert Shift:=xlDown
    
    ' コピー＆ペースト
    Set newRow = ws.Rows(ActiveCell.Row + 1)
    srcRow.Copy Destination:=newRow
    
    ' D列とJ列以外を空白に設定（GZ列まで）
    newRow.Columns("A:C").ClearContents
    newRow.Columns("E:I").ClearContents
    newRow.Columns("K:GZ").ClearContents
    
    Application.ScreenUpdating = True
End Sub





```

トグルボタン

```
Sub ToggleButton()
    Dim ActiveCellContent As String
    ActiveCellContent = ActiveCell.Value

    If ActiveCellContent = "OPEN" Then
        ActiveCell.Value = "CLOSE"
    ElseIf ActiveCellContent = "CLOSE" Then
        ActiveCell.Value = "OPEN"
    End If
End Sub

```

トグルボタン大、中、小

```

Sub TogglePriorityButton()
    Dim ActiveCellContent As String
    ActiveCellContent = ActiveCell.Value

    If ActiveCellContent = "" Then
        ActiveCell.Value = "小"
    ElseIf ActiveCellContent = "小" Then
        ActiveCell.Value = "中"
    ElseIf ActiveCellContent = "中" Then
        ActiveCell.Value = "大"
    ElseIf ActiveCellContent = "大" Then
        ActiveCell.Value = "小"
    End If
End Sub
```

ボタンクリックで増減

```
Sub DecreaseDueDate()
    ' アクティブセルが空でなく、日付形式であることを確認します。
    If Not IsEmpty(ActiveCell) And IsDate(ActiveCell.Value) Then
        ' 納期を1日減らします。
        ActiveCell.Value = ActiveCell.Value - 1
    End If
End Sub
```


進捗率の管理

```
' 進捗率を10ずつ増加させる
Sub IncreaseProgress()
    ' アクティブセルが空であれば0に設定します
    If IsEmpty(ActiveCell) Then
        ActiveCell.Value = 0
    End If
    
    ' 進捗率を10ずつ増加させ、100を超えないようにします
    If IsNumeric(ActiveCell.Value) Then
        ActiveCell.Value = Application.WorksheetFunction.Min(ActiveCell.Value + 10, 100)
    End If
End Sub

' 進捗率を10ずつ減少させる
Sub DecreaseProgress()
    ' アクティブセルが空であれば0に設定します
    If IsEmpty(ActiveCell) Then
        ActiveCell.Value = 0
    End If
    
    ' 進捗率を10ずつ減少させ、0を切らないようにします
    If IsNumeric(ActiveCell.Value) Then
        ActiveCell.Value = Application.WorksheetFunction.Max(ActiveCell.Value - 10, 0)
    End If
End Sub

```