月: 2019年9月

選択範囲の取消線を削除します。
納品時の作業で利用することあり。

Sub StrikethroughDel()
    For Each myCell In Selection
        textBefore = myCell.Value
        textAfter = ""
        For i = 1 To Len(textBefore)
            If myCell.Characters(Start:=i, Length:=1).Font.Strikethrough = False Then
                textAfter = textAfter & Mid(textBefore, i, 1)
            End If
        Next i
    Next myCell
End Sub

フォルダ内のJPGファイルをフォルダごとのシートを作成し、
そのシート内に自動で貼り付けします。

Sub JpgPut()

' JpgPut
' JPGファイルを貼り付ける。
' エビデンスが存在する1階層上のフォルダを指定する。(末尾\)
' フォルダ内のJPGファイルは100枚まで。
' 例)
' C:\work\ebi\を指定した場合、
' C:\work\ebi\imgフォルダ内のJPGファイルを貼り付ける。

    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.StatusBar = "処理中・・・"
    
    Dim count As Integer
    count = 0
    Dim folderPath As String ' 環境によって変更すること。
    folderPath = Worksheets(1).Cells(2, 1).Value
    
    Dim fileName As String
    fileName = Dir(folderPath & "\", vbDirectory)
    
    Dim n As Integer
    n = 0
    
    Dim fileNames(100) As String
    Do While fileName <> ""
        fileNames(n) = fileName
        n = n + 1
        fileName = Dir()
    Loop
    
    Dim i As Integer
    Dim j As Integer
    For j = 0 To n
        fileName = fileNames(j)
        If GetAttr(folderPath & "\" & fileName) And vbDirectory Then
            If fileName <> "." And fileName <> ".." And fileName <> "" Then
                i = 0
                Dim newSheet As Worksheet
                Set newSheet = Worksheets.Add()
                newSheet.Move after:=Worksheets(Worksheets.count)
                newSheet.Name = fileName
                
                Dim jpgPath As String
                jpgPath = Dir(folderPath & "\" & fileName & "\" & "*.JPG", vbNormal)
                Do While jpgPath <> ""
                
                    ' 画像の高さに合わせて「45」の数値を変更すること。
                    newSheet.Cells(i * 45 + 1, 1).Value = jpgPath
                    newSheet.Cells(i * 45 + 2, 2).Select
                    
                    ' Excel2010の場合はここから
                    ' 画像を1*1ポイントで貼り付け
                    Set myShape = Worksheets(fileName).Shapes.AddPicture( _
                    fileName:=folderPath & "\" & fileName & "\" & jpgPath, _
                    linkToFile:=False, _
                    saveWithdocument:=True, _
                    Left:=Selection.Left, _
                    Top:=Selection.Top, _
                    Width:=msoTrue, _
                    Height:=msoTrue)
                    ' 画像を元のサイズに変換(Heightの設定は不要かも)
                    ' Withを利用しないとオブジェクトエラーになる。
                    With myShape
                        LockAspecRatio = msoTrue
                        Hieght = 560
                    End With
                    'myShape.LockAspecRatio = msoTrue
                    'myShape.Hieght = 560
                    ' Excel2010の場合はここまで
                    
                    ' Excel2013の場合はここから
                    'Worksheets(fileName).Picutures.Insert fileName:=folderPath & "\" & fileName & "\" & jpgPath
                    ' Excel2013の場合はここまで
                    
                    i = i + 1
                    count = count + 1
                    jpgPath = Dir()
                Loop
                
            End If
        End If
    Next j
    
    Application.StatusBar = count & "個貼り付け完了"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub