pgbigorokuのブログ

プログラムの再利用できそうなコードをアップ

EXCEL VBA ファイル名から拡張子を抜いた文字を取得する 

Sub a()
    Debug.Print nstrGetFileName("c:\AA.pdf")
End Sub

'　ファイル名から拡張子を抜いた文字を取得する
'
'
' 引数：ファイル名
' 戻り値；ファイル名
'          フォルダ名は削除
'          拡張子は削除
' https://pgbigoroku.hatenablog.com/entry/2022/12/03/220510
'2022/12/3
'関連
' ファイル名から拡張子を取得する
'   https://pgbigoroku.hatenablog.com/entry/2022/12/03/011813
Private Function nstrGetFileName(ByVal pstrFilenName As String) As String
    Dim strFileName As String
    Dim intInstrRev As Integer
    Dim intInstrRevExtension As Integer
    strFileName = pstrFilenName
    intInstrRev = InStrRev(strFileName, "\")
    If intInstrRev > 0 Then
        strFileName = Mid(strFileName, intInstrRev + 1)
    Else
        strFileName = strFileName
    End If
    intInstrRevExtension = InStrRev(strFileName, ".")
    If intInstrRevExtension > 0 Then
        strFileName = Left(strFileName, intInstrRevExtension - 1)
    Else
        strFileName = strFileName
    End If
    nstrGetFileName = strFileName
End Function

EXCEL VBA WordファイルををPDFへ変換 

Sub a()
    Call nsubWordToPDF("D:\TEMP\テスト.doc", "D:\TEMP\テスト.pdf")
End Sub



'WordファイルををPDFへ変換
' 引数：pstrInputWordPath 変換前のWORDファイル名（フルパス）
'       pstrOutputPDFPath 出力のPOFファイル名（フルパス）
'https://pgbigoroku.hatenablog.com/entry/2022/12/03/213928
'バージョン 2022/12/3
Private Sub nsubWordToPDF(ByVal pstrInputWordPath As String, ByVal pstrOutputPDFPath As String)
    Dim wrdApp As Object
    Dim wrdTarget As Object
    Set wrdApp = CreateObject("Word.Application")
    Set wrdTarget = wrdApp.documents.Open(pstrInputWordPath, ReadOnly:=True)
    wrdTarget.ExportAsFixedFormat pstrOutputPDFPath, ExportFormat:=17
    wrdTarget.Close
    wrdApp.Quit
End Sub

EXCEL VBA 指定行を削除する 

'
'　指定行を削除する
'
'
' 引数：pwksTarget 対象シート
'       pintLineNo 削除する行番号
'       pblnEndLineNo (省略可)複数行削除する場合、最終行
' 戻り値：追加した行番号
' https://pgbigoroku.hatenablog.com/entry/2022/12/03/181917
' バージョン 2022/12/3
Private Sub nsubDeleteRow(ByRef pwksTarget As Worksheet, ByVal plngLineNo As Long, Optional ByVal pblnEndLineNo As Long = -1)
    '前処理、現在のアクティブブックを保存する。
    Dim wksActive As Worksheet
    Set wksActive = ActiveSheet
    
    '本処理ここから
    
    pwksTarget.Parent.Activate
    pwksTarget.Select
    
    If pblnEndLineNo <= plngLineNo Then
        pwksTarget.Rows(CStr(plngLineNo) & ":" & CStr(plngLineNo)).Select
    Else
        pwksTarget.Rows(CStr(plngLineNo) & ":" & CStr(pblnEndLineNo)).Select
    End If
    Selection.Delete Shift:=xlUp
    
    '本処理ここまで

    '後処理 処理前のアクディブブックに戻す
    wksActive.Parent.Activate
    wksActive.Select
End Sub

EXCEL VBA 新しい行を指定行の下に追加後、指定行のデータをコピーする。 

'
'　新しい行を指定行の下に追加後、指定行のデータをコピーする。
'
'
' 引数：pwksTarget 挿入するシート
'       pintLineNo コピーする行番号
' 戻り値：追加した行番号
' https://pgbigoroku.hatenablog.com/entry/2022/12/03/013417
' バージョン 2022/12/3
Private Function nlngCopywithData(ByRef pwksTarget As Worksheet, ByVal plngLineNo As Long) As Long
    '前処理、現在のアクティブブックを保存する。
    Dim wksActive As Worksheet
    Set wksActive = ActiveSheet
    
    '本処理ここから
    
    pwksTarget.Parent.Activate
    pwksTarget.Select
    pwksTarget.Rows(CStr(plngLineNo) & ":" & CStr(plngLineNo)).Select
    Selection.Copy
    pwksTarget.Rows(CStr(plngLineNo + 1) & ":" & CStr(plngLineNo + 1)).Select
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False
    nlngCopywithData = plngLineNo + 1
    
    '本処理ここまで

    '後処理 処理前のアクディブブックに戻す
    wksActive.Parent.Activate
    wksActive.Select

End Function

EXCEL VBA ファイル名から拡張子を取得する 

'
'　ファイル名から拡張子を取得する
'
'
' 引数：ファイル名
' 戻り値；拡張子
'          小文字で返す
'          拡張子が無い場合はLen(0)の文字列を返す
'          https://pgbigoroku.hatenablog.com/entry/2022/12/03/011813
'2022/12/1
Private Function nstrGetExtension(ByVal pstrFilenName As String) As String
    Dim strFilename As String
    Dim intInstrRev As Integer
    
    strFilename = pstrFilenName
    intInstrRev = InStrRev(strFilename, ".")
    If intInstrRev > 0 Then
        nstrGetExtension = LCase(Mid(strFilename, intInstrRev + 1))
    Else
        nstrGetExtension = ""
    End If
End Function

EXCEL VBA 列の幅を別シートにコピーする

列の幅を別シートにコピーするサンプルプログラムです。

Sub test()
    Call nsub列の幅を別シートにコピーする｡(Workbooks("Book1.xlsm").Worksheets("Sheet1"), Workbooks("Book2.xlsm").Worksheets("Sheet1"), 2, 8)
End Sub

' 列の幅を別シートにコピーする。
'
'https://pgbigoroku.hatenablog.com/entry/2022/09/11/234653
Public Sub nsub列の幅を別シートにコピーする｡(ByRef pshtFromSheet As Worksheet, _
                                        ByRef pstrToSheet As Worksheet, _
                                        ByVal pintStart列番号 As Integer, _
                                        ByVal pintEnd列番号 As Integer)
    Dim intCol As Integer
    For intCol = pintStart列番号 To pintEnd列番号
        pstrToSheet.Columns(intCol).ColumnWidth = pshtFromSheet.Columns(intCol).ColumnWidth
    Next
End Sub

EXCEL エクセルのマクロを実行できない（ActiveXが動かない）

おはようございます！

なぜか、突然エクセルのマクロ（正確にはシート上に張ったACTICEX）が動かなくなりました💦

治りましたので手順を
①Windows　Update（わたしはWindows１０です）
②Office　Update
　　Excelを起動（Windowsキーを押しながらRボタンを押す、excelと入力してエンター）
　　「こんばんは」の画面で、左下の「アカウント」を選択
　　「Office　更新プログラム」を選択

Office Update

③ディスプレイの解像度をすべて「推奨」にする。（ディスクトップ画面を右クリックで、「ディスプレイ設定」から選べます）
④再起動

これで使えました💦

まさか、解像度が問題だとは（笑）

追記、また再発しました（笑）
%USERPROFILE%\AppData\Local\Temp\Excel8.0\
フォルダを開けて
MSForms.exd
を消せば治りました！