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