Excel VBAのメモ

■■■セルの計算式を取得し、その計算式の参照先セルの左隣にある項目名に置き換え、メッセージボックスで表示するコード。ついでにクリップボードに保存する。

#If VBA7 Then
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal uFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As LongPtr, ByVal lpString2 As String) As LongPtr
#Else
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal uFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Long, ByVal lpString2 As String) As Long
#End If

Const GMEM_MOVEABLE = &H2
Const CF_TEXT = 1

Sub CopyToClipboard(Text As String)
    Dim hGlobalMemory As LongPtr
    Dim lpGlobalMemory As LongPtr
    Dim hWndCurrentWindow As LongPtr
    
    ' Open the clipboard
    If OpenClipboard(hWndCurrentWindow) Then
        ' Clear the clipboard
        EmptyClipboard
        
        ' Allocate moveable global memory
        hGlobalMemory = GlobalAlloc(GMEM_MOVEABLE, Len(Text) + 1)
        
        ' Lock the allocated memory and get a pointer to it
        lpGlobalMemory = GlobalLock(hGlobalMemory)
        
        ' Copy the string to the allocated memory
        lstrcpy lpGlobalMemory, Text
        
        ' Unlock the memory
        GlobalUnlock hGlobalMemory
        
        ' Set the clipboard data
        SetClipboardData CF_TEXT, hGlobalMemory
        
        ' Close the clipboard
        CloseClipboard
    End If
End Sub

Sub ShowFormulaWithItemNames()
    Dim targetCell As Range
    Dim formula As String
    Dim cellReferences As Range
    Dim refCell As Range
    Dim refAddress As String
    Dim absRefAddress As String
    Dim refItem As String
    Dim modifiedFormula As String
    Dim sheetName As String
    
    ' 現在選択されているセルを対象とする
    Set targetCell = ActiveCell
    
    ' 指定セルの計算式を取得
    formula = targetCell.Formula
    
    ' 計算式がない場合は終了
    If formula = "" Then
        MsgBox "選択されたセルには計算式がありません。"
        Exit Sub
    End If
    
    ' 計算式の参照先を取得
    On Error Resume Next
    Set cellReferences = targetCell.Precedents
    On Error GoTo 0
    
    ' 参照セルがない場合は終了
    If cellReferences Is Nothing Then
        MsgBox "計算式にはセル参照がありません。"
        Exit Sub
    End If
    
    ' 変更後の計算式の初期化
    modifiedFormula = formula
    
    ' 参照先セルごとに項目名を取得して置換
    For Each refCell In cellReferences
        ' 参照セルの相対アドレスを取得
        refAddress = refCell.Address(False, False)
        
        ' 参照セルの絶対アドレスを取得($A$1などの形式)
        absRefAddress = refCell.Address(True, True)
        
        ' 参照セルが他のシートの場合はシート名を取得
        sheetName = refCell.Worksheet.Name
        
        ' 他のシートの参照を含む場合はシート名を加える
        If sheetName <> targetCell.Worksheet.Name Then
            refAddress = sheetName & "!" & refAddress
            absRefAddress = sheetName & "!" & absRefAddress
        End If
        
        ' 参照セルの左側にある項目名を取得
        refItem = refCell.Offset(0, -1).Value
        
        ' 計算式内のセル参照を項目名に置き換える(絶対参照と相対参照、シート参照も対応)
        modifiedFormula = Replace(modifiedFormula, refAddress, refItem)
        modifiedFormula = Replace(modifiedFormula, absRefAddress, refItem)
    Next refCell
    
    ' MsgBoxに元の計算式と変更後の計算式を表示
    MsgBox "元の計算式: " & vbCrLf & formula & vbCrLf & vbCrLf & "変更後の計算式: " & vbCrLf & modifiedFormula
    
    ' 変更後の計算式をクリップボードに保存
    CopyToClipboard modifiedFormula
End Sub


■■■ファイルに出力

Sub SaveFormulaToFile(modifiedFormula As String)
    Dim filePath As String
    Dim fileNum As Integer
    
    ' 保存するファイルのパスを指定
    filePath = Application.DefaultFilePath & "\ModifiedFormula.txt"
    
    ' 新しいファイルを作成または既存ファイルを開く
    fileNum = FreeFile
    Open filePath For Output As fileNum
    
    ' ファイルに書き込み
    Print #fileNum, modifiedFormula
    
    ' ファイルを閉じる
    Close fileNum
    
    ' 保存完了のメッセージ
    MsgBox "計算式がファイルに保存されました。" & vbCrLf & "ファイルパス: " & filePath
End Sub

■■■シート名を取得する。

Sub CreateSheetAndListSheetNamesInActiveWorkbook()
    Dim newSheet As Worksheet
    Dim ws As Worksheet
    Dim i As Integer
    Dim activeWb As Workbook
    
    ' 実行時にアクティブなワークブックを指定
    Set activeWb = ActiveWorkbook
    
    ' 新しいシートを作成し、1番目に移動
    Set newSheet = activeWb.Sheets.Add(Before:=activeWb.Sheets(1))
    newSheet.Name = "SheetList" ' 必要に応じてシート名を変更
    
    ' 他のシートのシート名を取得してA列に記載
    i = 1
    For Each ws In activeWb.Sheets
        If ws.Name <> newSheet.Name Then ' 新しいシート自体は含めない
            newSheet.Cells(i, 1).Value = ws.Name
            i = i + 1
        End If
    Next ws
End Sub

■■■条件付き書式:他シートの値によって背景色を変更させる指定

Sub 条件付き書式を相対参照で設定_列対応版()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sheet1") ' 条件を設定するシート
    Set ws2 = ThisWorkbook.Sheets("Sheet2") ' 参照するシート

    Dim rng As Range
    Set rng = ws1.Range("A1:B2") ' 条件付き書式を適用する範囲

    ' 既存の条件付き書式をクリア
    rng.FormatConditions.Delete

    ' OFFSETを使って行と列の相対参照に対応
    ' シート2のF列、G列のセルを動的に参照
    With rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=OFFSET(Sheet2!$F$11,ROW(A1)-1,COLUMN(A1)-1)=0")
        .Interior.Color = RGB(255, 0, 0) ' 背景色を赤に設定
    End With
End Sub

■■■自身を別のフォルダにコピー保存する

Sub SaveWorkbookCopyInNewFolder()
    Dim wb As Workbook
    Dim originalPath As String
    Dim newFolderPath As String
    Dim newFilePath As String
    Dim folderName As String
    Dim newFileName As String
    
    ' 現在のワークブックを取得
    Set wb = ThisWorkbook ' or ActiveWorkbook if you prefer the active one
    
    ' ワークブックのパス(ファイル名を除く)
    originalPath = wb.Path
    
    ' 新しいフォルダ名を指定(例: "コピー保存"フォルダ)
    folderName = "コピー保存"
    
    ' 新しいフォルダのパス
    newFolderPath = originalPath & "\" & folderName
    
    ' フォルダが存在しない場合は作成
    If Dir(newFolderPath, vbDirectory) = "" Then
        MkDir newFolderPath
    End If
    
    ' 新しいファイル名を指定(例: "元のファイル名_コピー.xlsx")
    newFileName = Left(wb.Name, InStrRev(wb.Name, ".") - 1) & "_コピー.xlsx"
    
    ' 保存するファイルのパスを作成
    newFilePath = newFolderPath & "\" & newFileName
    
    ' 自身のワークブックを変更せずにコピーを保存
    wb.SaveCopyAs newFilePath
    
    MsgBox "ファイルは '" & newFolderPath & "' に '" & newFileName & "' という名前でコピーされました。", vbInformation
End Sub

■■■最低値を抽出(エラーセル含む場合対応版

Sub FindMinValueWithPositionIgnoreErrors()
    Dim ws As Worksheet
    Dim searchRange As Range
    Dim cell As Range
    Dim minValue As Double
    Dim minRow As Long
    Dim minColumn As Long
    Dim firstValueSet As Boolean
    
    ' 初期化
    minValue = 0
    firstValueSet = False
    
    ' シート1を設定
    Set ws = ThisWorkbook.Sheets("シート1")
    
    ' C24:KP24の範囲を設定
    Set searchRange = ws.Range("C24:KP24")
    
    ' エラーを無視して最低値を取得
    For Each cell In searchRange
        If Not IsError(cell.Value) Then ' エラーが無い場合のみ処理
            If Not firstValueSet Then
                minValue = cell.Value
                minRow = cell.Row
                minColumn = cell.Column
                firstValueSet = True
            ElseIf cell.Value < minValue Then
                minValue = cell.Value
                minRow = cell.Row
                minColumn = cell.Column
            End If
        End If
    Next cell
    
    ' 結果の表示
    If firstValueSet Then
        MsgBox "C24:KP24のエラーを除いた最低値は " & minValue & " です。" & vbCrLf & _
               "行番号: " & minRow & vbCrLf & _
               "列番号: " & minColumn, vbInformation
    Else
        MsgBox "範囲内に数値データがありません。", vbExclamation
    End If
End Sub

■■■ファイルへのリンク

Sub CreateRelativeLink()
    Dim filePath As String
    Dim relativePath As String
    Dim saveFolder As String
    Dim fileName As String
    Dim baseFolder As String
    
    ' 保存するフォルダを指定
    saveFolder = "保存するフォルダ名"
    fileName = "保存するファイル名.xlsx" ' 保存するファイル名を指定
    
    ' 現在のファイルのディレクトリを基準とする
    baseFolder = ThisWorkbook.Path
    filePath = baseFolder & "\" & saveFolder & "\" & fileName
    
    ' 保存先のフォルダを作成(存在しない場合)
    If Dir(baseFolder & "\" & saveFolder, vbDirectory) = "" Then
        MkDir baseFolder & "\" & saveFolder
    End If
    
    ' ファイルを保存(例としてアクティブなブックをコピーして保存)
    ThisWorkbook.SaveCopyAs filePath
    
    ' 相対パスを作成
    relativePath = saveFolder & "\" & fileName
    
    ' 相対パスでリンクをセルに貼り付け
    With ThisWorkbook.Sheets(1).Range("A1") ' リンクを貼るセルを指定
        .Value = relativePath
        .Hyperlinks.Add Anchor:=.Cells(1, 1), Address:=relativePath, TextToDisplay:=fileName
    End With
End Sub

■■■シートBのセル範囲D34~AG34内の値がC13と一致している列で
シートBのセル範囲C3~C33内の値がシートAのF45の値と一致している行の値

=INDEX(B!D3:AG33, MATCH(F45, B!C3:C33, 0), MATCH(C13, B!D34:AG34, 0))

コメント

タイトルとURLをコピーしました