Public public_row1, public_col1, public_row2, public_col2
Sub A_backupany()
Dim myBook As Workbook
Dim src As String
src = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
Dim destName As String
destName = "bk" & Format(Date, "yyymmdd") & "-" & Format(time, "hhmmss") & "" & ActiveWorkbook.Name
Dim dest, destPath As String
destPath = ActiveWorkbook.Path & "\old" ‘末尾に\が必要
‘oldフォルダが無ければ作成
If Dir(destPath) = "" Then
On Error Resume Next
MkDir destPath
End If
destPath = destPath & "\"
Dim objFSO As Object, txtSrc As String, txtDest
Set objFSO = CreateObject("Scripting.FileSystemObject")
‘objFSO.CopyFile src, destPath
objFSO.CopyFile src, destPath & destName
‘OneDriveへの保存
If InStr(destPath, "FQU1") <> 0 Then
destPath = "C:\Users\yamag\OneDrive\BACKUP\FQU1\"
objFSO.CopyFile src, destPath & destName
End If
End Sub
Sub A_z図_circleRed()
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, 50, 15).Select
‘Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
.Visible = msoFalse
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 2.25
End With
End Sub
Sub cell_linkedCell2MD()
‘ハイパーリンクが貼られているセルからタイトルとURLをmd形式で取得
Dim str, link, md
str = Application.InputBox("ページ名の指定", "ページ名", Selection.Value)
link = Selection.Hyperlinks(1).Address
md = "" & str & ""
クリップボード操作.toClipBoard (md)
End Sub
‘【VBA】ハイパーリンクの設定と取得【Hyperlinksを使う】
Sub Web辞書サービスの串刺し検索()
‘選択したセルのテキストを串刺し検索する
With CreateObject("Wscript.Shell")
.Run "http://www.google.co.jp/search?q=%22″ & Selection.Text & “%22"
.Run "http://eow.alc.co.jp/” & Selection.Text
.Run "http://ejje.weblio.jp/content/” & Selection.Text
.Run "http://ja.wikipedia.org/wiki/” & Selection.Text
End With
End Sub
Sub sheetAddKakeibo()
‘家計簿用シート追加
Call sheetAddF(13, 3) ‘第一引数：シート一覧の見出し行の下の行、第二引数：ハイパーリンク列
End Sub
Function sheetAddF(rowStart As Integer, colStart As Integer)
‘第一引数：シート一覧の見出し行の下の行、第二引数：ハイパーリンク列
‘家計簿用シート追加
Dim sheetName As String
sheetName = Application.InputBox("シート名の入力", "シート名の入力")
Dim sheetActive As Worksheet
Set sheetActive = ActiveSheet
‘シート一覧よりシートを追加
Dim ws As Worksheet
Set ws = Sheets.Add(After:=ActiveSheet)
ws.Name = sheetName
ws.Select
Range("A1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"’00-シート一覧’!A1", TextToDisplay:="’00-シート一覧’"
Rows(2).Select
ActiveWindow.FreezePanes = True
sheetActive.Select
Rows(rowStart).Select
Selection.EntireRow.Insert
Range("C13:E13").Select
With Range(Cells(rowStart, 1), Cells(rowStart, 10))
.Interior.Pattern = xlNone
.Interior.TintAndShade = 0
.Interior.PatternTintAndShade = 0
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
sheetActive.Select
Cells(rowStart, colStart).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=sheetName, TextToDisplay:=sheetName
Cells(rowStart, colStart + 1).Select
End Function
Sub LinkeOpenAndRow2top()
Call row2topAndOpenLinkF(2, 2) ‘引数：タイトル行、リンクが貼り付けてあるセルの列
End Sub
Sub LinkeOpenAndRow2topMF() ‘引数：タイトル行、リンクが貼り付けてあるセルの列
Call row2topAndOpenLinkF(15, 3)
End Sub
Function row2topAndOpenLinkF(rowTitle As Integer, col As Integer)
‘引数：タイトル行、リンクが貼り付けてあるセルの列
‘選択した行のハイパーリンクを開き、行を上に移動する。
‘Range("C6").Activate
Rows(Selection.row).Cut
Rows(rowTitle + 1).Select
Selection.Insert Shift:=xlDown
Cells(rowTitle + 1, col).Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
End Function
Sub cellSplit2MultiCells()
‘選択したセルのテキストが"。"や"."や"?"を含む場合、それらを区切りとしてテキストを複数のセルに分割する。
Application.ScreenUpdating = False
Dim i As Long, tmp As Variant
Dim rowNext As Integer
Dim splitter As String
If InStr(Selection, "。") <> 0 Then
tmp = Split(Selection, "。")
splitter = "。"
End If
If InStr(Selection, ".") <> 0 Then
tmp = Split(Selection, ".")
splitter = "."
End If
If InStr(Selection, "?") <> 0 Then
tmp = Split(Selection, "?")
splitter = "?"
End If
If splitter = "" Then
splitter = Application.InputBox("区切り入力")
If InStr(Selection, splitter) Then
tmp = Split(Selection.splitter)
Else
MsgBox "対象の区切りは存在しませんでした。"
Exit Sub
End If
End If
If splitter = "" Then Exit Sub
Selection.Value = tmp(0) & splitter
rowNext = Selection.row + 1
For i = 1 To UBound(tmp)
Cells(rowNext, Selection.Column).Insert Shift:=xlDown
If tmp(i) <> "" Then Cells(rowNext, Selection.Column) = Replace(tmp(i) & splitter, splitter & splitter, "")
rowNext = rowNext + 1
Next i
If Selection.Offset(1, 0).Value = "" Then Selection.Offset(1, 0).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub
Sub cell_mergeSelection2FirstCell4FCe()
Call cell_mergeSelection2FirstCell("noReturnWithSpace", "セル") ‘■引数■・types:"noReturnWithoutSpace","noReturnWithSpace,"Return" ・process: "セル","cb"
End Sub
Sub cell_mergeSelection2FirstCell4FCj()
Call cell_mergeSelection2FirstCell("noReturnWithoutSpace", "セル") ‘■引数■・types:"noReturnWithoutSpace","noReturnWithSpace,"Return" ・process: "セル","cb"
End Sub
Sub cell_mergeSelection2CB()
Call cell_mergeSelection2FirstCell("Return", "cb") ‘■引数■・types:"noReturnWithoutSpace","noReturnWithSpace,"Return" ・process: "セル","cb"
End Sub
Function cell_mergeSelection2FirstCell(types As String, process As String)
‘■引数■・types:"noReturnWithoutSpace","noReturnWithSpace,"Return" ・process: "セル","cb"
Application.ScreenUpdating = False
Dim str, c
Dim cellFirst As Range
Dim rowFirst, rowNum, col, hantei
col = Selection(1).Column
‘hantei = MsgBox("改行無しで連結する場合は「はい」、改行を入れる場合は「いいえ」を選択", vbYesNo + vbQuestion, "改行処理")
hantei = 6
For Each c In Selection
rowNum = rowNum + 1
If cellFirst Is Nothing Then
Set cellFirst = c
rowFirst = c.row
End If
Select Case types
Case "noReturnWithoutSpace"
str = str & c.Value
Case "noReturnWithSpace"
str = str & c.Value & " "
Case "Return" ‘no
str = str & vbCrLf & c.Value
Case 2
Exit Function
End Select
Next
Select Case process
Case "セル"
Range(Cells(cellFirst.row + 1, col), Cells(cellFirst.row + rowNum – 1, col)).Delete Shift:=xlUp
With cellFirst
.Select
.Value = str
.WrapText = True
End With
Case "cb"
クリップボード操作.toClipBoard (str)
End Select
Application.ScreenUpdating = True
End Function
Sub inbox_WBS()
Call inbox("【WBS】英語教師PJ.xlsm", "C:\Users\yamag\OneDrive\English\英語教師PJ\【WBS】英語教師PJ.xlsm", "INBOX", 5, 3, 1) ‘引数：ファイル名、フルパス、シート名、最初の行、タスク列、日付列
End Sub
Function inbox(fileName As String, fileFullPath As String, sheetName As String, rowStart, colTask, colDate)
‘引数：ファイル名、フルパス、シート名、最初の行、タスク列、日付列
Dim bookMemo As Object
Dim str
Dim wb As Workbook
Dim counta As Integer
For Each wb In Workbooks
If wb.Name = fileName Then
counta = 1
Exit For
End If
Next
If counta = 0 Then Workbooks.Open fileFullPath
str = Application.InputBox("INBOXタスクを入力。クリップボード上のリンクをタスクに貼り付ける場合は空白のままOKをクリック", "タスク入力")
If str <> "" Then
With Workbooks(fileName).Worksheets(sheetName)
.Rows(rowStart).Insert Shift:=xlDown
.Cells(rowStart, colTask).Value = str
.Cells(rowStart, colTask).Font.Bold = False
‘ .Cells(rowStart, colDate).Value = Date
‘ .Cells(rowStart, colDate).Font.Size = 6
End With
Else
With Workbooks(fileName).Worksheets(sheetName)
.Rows(rowStart).Insert Shift:=xlDown
.Cells(rowStart, colTask).Select
.Cells(rowStart, colTask).Font.Bold = False
‘ .Cells(rowStart, colDate).Value = Date
‘ .Cells(rowStart, colDate).Font.Size = 6
End With
Call A__HyperLinkOfPathFromMD
End If
If str = "" Then Exit Function
End Function
Sub sheet_grid()
‘グリッド線の幅を変更
Range(Columns(1), Columns(1000)).ColumnWidth = 0.5
Range(Rows(1), Rows(1000)).RowHeight = 5
Cells(1, 1).Select
End Sub
Sub cell_セル値のスイッチ_水平()
‘2つのセルを選択し、値を入れ替える
Application.ScreenUpdating = False
Dim r ‘for loop
Dim str1, str2
Dim col
col = Selection(1).Column ‘選択範囲の最初の列
Dim myRange As Range ‘選択範囲を格納
Set myRange = Selection
For r = myRange(1).row To myRange(Selection.Count).row
str1 = Cells(r, col).Value
str2 = Cells(r, col + 1).Value
Cells(r, col).Value = str2
Cells(r, col + 1).Value = str1
Next
Application.ScreenUpdating = True
End Sub
Sub cell_セル値のスイッチ_垂直()
‘2つのセルを選択し、値を入れ替える
Application.ScreenUpdating = False
Dim r ‘for loop
Dim str1, str2
Dim col
col = Selection(1).Column ‘選択範囲の最初の列
Dim myRange As Range ‘選択範囲を格納
Set myRange = Selection
str1 = Cells(myRange(1).row, col).Value
str2 = Cells(myRange(2).row, col).Value
Cells(myRange(1).row, col).Value = str2
Cells(myRange(2).row, col).Value = str1
Application.ScreenUpdating = True
End Sub
Sub cell_セル内箇条書き()
Dim sep
sep = Application.InputBox("箇条書き記号を記入してください", "箇条書き記号指定", "・")
With Selection
.Value = sep & .Value
.Replace vbLf, vbLf & sep, xlPart
.Replace vbCrLf, vbCrLf & sep, xlPart
.Replace crLf, crLf & sep, xlPart
.Replace vbCr, vbCr & sep, xlPart
End With
End Sub
Sub cell_trimSpace()
‘2023/1/20：機能しない。。。
Application.ScreenUpdating = False
Dim c, hantei
hantei = MsgBox("末尾のスペースを削除する場合は「はい」、先頭と末尾の両方は「いいえ」を選択", vbYesNoCancel)
If hantei = 2 Then
MsgBox "処理を取りやめます"
Exit Sub
End If
For Each c In Selection
Select Case hantei
Case 6 ‘yes
c.Value = RTrim(c.Value)
Case 7 ‘no
c.Value = Trim(c.Value)
Case 2
Exit Sub
End Select
Next
Application.ScreenUpdating = True
MsgBox "done!"
End Sub
Sub A_cellValuesAtMultiCellsMerge2CB()
‘選択した複数のセルをマージしCBへ格納。箇条書き記号の有無も設定可能。
Const sep As String = "・"
‘Const hanteiSep As Integer = 6
Dim str, c, hantei
Dim cellTarget As Variant
Dim col1 As Integer
col1 = Selection(1).Column
Dim hanteiSep
hanteiSep = MsgBox("冒頭にドットを記載する場合は「はい」、記載しない場合は「いいえ」を選択", vbYesNo + vbQuestion, "冒頭のドットの処理")
‘値をマージする
For Each c In Selection
If c.Value <> "" Then
If str = "" Then
Select Case hanteiSep
Case 7
str = c.Value
Case 6
str = sep & c.Value
End Select
Else
Select Case hanteiSep
Case 7
Select Case c.Column – col1
Case 0
str = str & vbCrLf & c.Value
Case 1
str = str & vbCrLf & " " & " " & c.Value
Case 2
str = str & vbCrLf & " " & " " & " " & c.Value
Case 3
str = str & vbCrLf & " " & " " & " " & " " & " " & " " & c.Value
End Select
Case 6
Select Case c.Column – col1
Case 0
str = str & vbCrLf & sep & c.Value
Case 1
str = str & vbCrLf & " " & " " & sep & c.Value
Case 2
str = str & vbCrLf & " " & " " & " " & sep & c.Value
Case 3
str = str & vbCrLf & " " & " " & " " & " " & " " & " " & sep & c.Value
End Select
‘str = sep & str
End Select
End If
End If
Next
‘Debug.Print str
クリップボード操作.toClipBoard (str)
End Sub
Sub A_book_SaveAllBooks()
A_book_SaveAllBooksF (False)
End Sub
Sub A_book_SaveAllBooksAndCloseExcel()
A_book_SaveAllBooksF (True)
End Sub
Function A_book_SaveAllBooksF(hantei As Boolean)
‘EXCEL VBA ブックを閉じる（ﾌﾞｯｸ全てを保存して閉じる・変更されていれば保存・保存しないで閉じる）
Dim AllBook As Workbook
Application.DisplayAlerts = True ‘保存する際の警告メッセージを無視します。
For Each AllBook In Workbooks ‘開いているワークブック全てをループします。
If InStr(AllBook.Path, "FDU1") <> 0 Then Call A_backup_any
Next AllBook
For Each AllBook In Workbooks ‘開いているワークブック全てをループします。
AllBook.Save ‘ワークブック全てを保存（Save）します。
Next AllBook
Application.DisplayAlerts = False ‘警告メッセージの無視を解除します。
‘hantei = MsgBox("上書き保存のみの場合は「はい」、保存後全ブックを閉じる場合は「いいえ」を選択", vbYesNo + vbQuestion, "改行処理")
If hantei = True Then Application.Quit ‘EXCELを終了
End Function
Sub A_row_rowInsertAndPasteValueFromCB()
‘選択したセルに行を追加し、選択セルにクリップボードの値を貼り付ける
Dim str
str = クリップボード操作.fromClipBoard
Dim start_char
start_char = 1
Dim numIf
Dim col_original
col_original = Selection.Column
Dim row_original
row_original = Selection.row
Do While InStr(start_char, str, vbCrLf) <> False
start_char = InStr(start_char, str, vbCrLf) + 1
numIf = numIf + 1
Loop
Rows("" & row_original & ":" & row_original + numIf & "").Select
Selection.Insert
Cells(row_original, col_original).Select
ActiveSheet.Paste
End Sub
Sub rowInsertMultiRows()
‘複数の行を挿入する
Application.ScreenUpdating = False
Dim n
n = Application.InputBox("挿入行数を指定する。", "挿入行数の指定", 5)
For i = 1 To n
Rows(ActiveCell.row + 1).Insert
Next
Application.ScreenUpdating = True
End Sub
Sub commentAdd()
‘コメントを挿入する。
Dim str
str = Application.InputBox("コメントに入力するメッセージを入力", "メッセージ入力")
func_CommentAdd (str)
End Sub
Sub commentAddFromCB()
‘CBの値よりセルコメントを生成する。
Dim str
str = クリップボード操作.fromClipBoard
func_CommentAdd (str)
End Sub
Function func_CommentAdd(str)
‘コメントを入力し、体裁を整える
Application.ScreenUpdating = False
‘variables,constants
Const sep1 As String = "。 "
Const sep2 As String = ". "
Const sep3 As String = "\n"
If str = False Then Exit Function
str = Replace(str, sep1, sep1 & vbLf)
str = Replace(str, sep2, sep2 & vbLf)
str = Replace(str, sep3, vbLf)
With Selection
On Error Resume Next
.AddComment
.Comment.Visible = False
.Comment.Text Text:=str
End With
Call func_CommentPositionReset
End Function
Function func_CommentPositionReset()
Dim myRange As Range
For Each myRange In Cells.SpecialCells(xlCellTypeComments)
With myRange.Comment.Shape
.Top = myRange.Top
.Left = myRange.Offset(, 1).Left
.TextFrame.AutoSize = True
.TextFrame.Characters.Font.Size = 9
.TextFrame.Characters.Font.Bold = False
.TextFrame.AutoSize = True
.AutoShapeType = msoShapeRound1Rectangle
.TextFrame.Characters.Font.color = vbBlack
End With
Next
Application.ScreenUpdating = True
End Function
Sub row_previousRowRetain1()
‘現在の行をパブリック変数に保持する
public_row1 = Selection.row
public_col1 = Selection.Column
Cells(1, 9).Value = public_row1
Dim str
‘If ActiveSheet.Name Like "CL" Then
” Cells(1, 22).Value = public_row1 & "行"
‘ str = Cells(public_row1, 6).Value & ":" & Cells(public_row1, 1).Value & "-" & Cells(public_row1, 5).Value
” Cells(1, 23).Value = str
‘ クリップボード操作.toClipBoard (str)
‘End If
End Sub
Sub row_GoBack2PrevRow1()
‘パブリック変数に保持した行に戻る
Cells(public_row1, public_col1).Select
End Sub
Sub row_previousRowRetain2()
‘現在の行をパブリック変数に保持する
public_row2 = Selection.row
public_col2 = Selection.Column
Dim str
If ActiveSheet.Name Like "CL" Then
‘Cells(1, 24).Value = public_row2 & "行"
str = Cells(public_row2, 6).Value & ":" & Cells(public_row2, 1).Value & "-" & Cells(public_row2, 5).Value
‘Cells(1, 25).Value = str
クリップボード操作.toClipBoard (str)
End If
End Sub
Sub row_GoBack2PrevRow2()
‘パブリック変数に保持した行に戻る
Cells(public_row2, public_col2).Select
End Sub
Sub A_z図_xlMoveAndSizeANDmargin0()
‘図形のマージンをゼロにし、グループ化時に図形が溢れないようにする
Dim cell
Set cell = Selection
With cell.ShapeRange.TextFrame2
.MarginRight = 0
.MarginLeft = 0
.MarginTop = 0
.MarginBottom = 0
End With
ActiveSheet.DrawingObjects.Select
Selection.Placement = xlMoveAndSize
Application.CommandBars("Format Object").Visible = False
End Sub
Sub cellk改行削除()
Dim rngTarget As Range
Set rngTarget = Selection
rngTarget.Replace vbLf, "", xlPart
End Sub
Sub sheetsCreatingIndex()
‘選択したセルから下に全シートのインデックスリストを作成する。
‘Excelで目次（シートへのリンク）をつくるマクロ | EX-IT 効率化で独立を楽しく
Dim i
For i = 1 To Worksheets.Count
ActiveSheet.Hyperlinks.Add Anchor:=Range("b" & i + 3),
Address:="",
SubAddress:=Worksheets(i).Name & "!A1", _
TextToDisplay:=Worksheets(i).Name
Next
End Sub
Sub SheetNames_get()
‘全シート名を一行の値として出力（カンマ区切り）
Dim str
For Each i In ActiveWorkbook.Sheets
If str = "" Then
str = " ※シート名:" & i.Name
Else
str = str & ", " & i.Name
End If
Next i
Debug.Print str
クリップボード操作.toClipBoard (str)
End Sub
Sub rowInsert4grouping()
Dim col
col = Selection.Columns
Rows(Selection.row).Copy
Rows(Selection.row).Insert
Rows(Selection.row – 1).Select
Selection.ClearContents
Cells(Selection.row, col).Select
End Sub
Sub z図_MoveSettingForAllImages()
‘ ImageMoveSettingForAllImages Macro
Dim cell
Set cell = Selection
ActiveSheet.DrawingObjects.Select
Selection.Placement = xlMoveAndSize
Application.CommandBars("Format Object").Visible = False
cell.Select
End Sub
Sub A_z図_ResizeCapture_70x100()
Call z図_MoveSettingForAllImages
Set selectedShape = Selection.ShapeRange
With selectedShape
.LockAspectRatio = msoTrue
.Height = 70
.Width = 100
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 1
End With
End Sub
Sub A_z図_ResizeCapture_250x350()
Call z図_MoveSettingForAllImages
Set selectedShape = Selection.ShapeRange
With selectedShape
.LockAspectRatio = msoTrue
.Height = 250
.Width = 350
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 1
End With
End Sub
Sub A_cellDotAdd2TopOfMultiCells()
Const str = "・"
Const NgStr = "#"
Dim c
For Each c In Selection
If Left(c.Value, 1) <> NgStr And c.Value <> "" Then
c.Value = str & c.Value
End If
Next c
End Sub
Sub cellDotDeleteTopOfMultiCellsl()
Const str = "・"
‘Const str2 = "’- "
Const NgStr = "#"
Dim c
For Each c In Selection
If c.Value <> "" Then
c.Value = Replace(c.Value, str, "")
End If
Next
End Sub
Sub cellDashAdd2TopOfMultiCells()
Const str = "’- "
Const NgStr = "#"
Dim c
For Each c In Selection
If Left(c.Value, 1) <> NgStr And c.Value <> "" Then
c.Value = str & c.Value
End If
Next c
End Sub
Sub A_z図_外枠線()
‘ ActiveSheet.Shapes.Range(Array("Picture 1")).Select
‘ Application.CommandBars("Format Object").Visible = False
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = -0.5
.ForeColor.Brightness = 0
End With
End Sub
Sub cellIncrement()
Selection.Value = Selection.Value + 1
End Sub
Sub Sample1()
Dim mySheet As Worksheet
Dim myRow As Long
myRow = 1
For Each mySheet In Worksheets ‘—(1)
Cells(myRow, 1).Value = mySheet.Name
myRow = myRow + 1
Next
End Sub
Function HyperLinkOfPathFromMD(titleSRC As Boolean)
‘■用途：クリップボードのMD形式のタイトル・URLをリンク化
‘引数：セルの文言を"SRC"としたい場合はTrue、MDのタイトルにしたい場合はFalse
Dim char
Dim strPath, strTitle As String
Dim dimpos As Integer ‘文字列のURLの切れ目
strPath = クリップボード操作.fromClipBoard
Set fso = CreateObject("Scripting.FileSystemObject")
If strPath = "" Then
MsgBox "クリップボードが空です"
Exit Function
End If
dimpos = InStr(1, strPath, "](") ‘MDか否かの判定用
Dim hoge
hoge = 0
Select Case dimpos
Case 0 ‘MDでなければ
If titleSRC = True Then
strTitle = "src"
Else
strTitle = fso.GetFileName(strPath)
End If
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=strPath, TextToDisplay:=strTitle
Case Else
If titleSRC = True Then
strTitle = "src"
Else
strTitle = Mid(strPath, 2, dimpos – 2)
End If
strPath = Mid(strPath, dimpos + 2, Len(strPath))
strPath = Replace(strPath, ")", "")
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=strPath, TextToDisplay:=strTitle
End Select
Selection.AddComment strPath
End Function
Sub AHyperLinkOfPathFromMD()
HyperLinkOfPathFromMD (False)
End Sub
Sub AHyperLinkOfPathFromMD_AS_SRC()
HyperLinkOfPathFromMD (True)
End Sub
Sub OpenMDLink()
Call OpenLinkOfhFromMD(Selection.Value)
End Sub
Function OpenLinkOfhFromMD(strPath As String)
‘■用途：MD形式のタイトル・URLからリンクを開く
‘★：クリップボード整備してからこのコードを完成させる
Dim char
Dim dimpos As Integer ‘文字列のURLの切れ目
dimpos = InStr(1, strPath, "](")
strPath = Mid(strPath, dimpos + 2, Len(strPath) – 1)
strPath = Replace(strPath, ")", "")
Dim WSH
Set WSH = CreateObject("Wscript.Shell")
WSH.Run strPath, 3
Set WSH = Nothing
End Function
Sub A_hyperLinkFromFilePath()
Dim strPath
strPath = クリップボード操作.fromClipBoard
Call hyperLinkFromFilePath(strPath)
End Sub
Function hyperLinkFromFilePath(strPath)
Dim char As String, strTitle As String
If strPath = "" Then MsgBox "Clipboard is empty."
For i = Len(strPath) To 1 Step -1
char = Mid(strPath, i, 1)
If char = "\" Then
Exit For
Else
If char = "." Then fileFlag = 1
End If
strTitle = char & strTitle
Next i
strTitle = Replace(strTitle, """", "")
strTitle = Replace(strTitle, ">", "")
strPath = Replace(strPath, """", "")
ActiveSheet.Hyperlinks.Add Selection, strPath, TextToDisplay:=strTitle
On Error Resume Next
Selection.AddComment strPath
End Function
Sub rowInsert()
Call f_row_insert
End Sub
Function f_row_insert()
Application.ScreenUpdating = False
‘ Keyboard Shortcut: Ctrl+Shift+I
Dim col As Integer
col = Selection.Column
Dim c
Dim r
r = Selection.row
Rows(r).Insert
Rows(r).ClearFormats
Rows(r).VerticalAlignment = xlTop
Application.ScreenUpdating = True
End Function
コメントを残す