シートの数式の有るセルに色をつけ灰色罫線を引くと削除する実験 Excel2000 VBA [Excel2000 VBA独習]
シートの数式の有るセルに色をつけ灰色罫線を引くと削除する実験 Excel2000 VBA
Sub 数式に色()
'シート全体の数式の有るセルに背景色設定する
With Cells 'シート全体
On Error Resume Next
.SpecialCells(xlCellTypeFormulas).Interior.Color = RGB(255, 244, 74)
.SpecialCells(xlCellTypeFormulas).Borders.Color = RGB(200, 200, 200)
End With
End Sub
Sub 数式にある色を消す2()
'シート全体の数式に設定した背景色と罫線を無効にする
Cells.SpecialCells(xlCellTypeFormulas).Select
Selection.Interior.ColorIndex = xlNone
Selection.Borders.LineStyle = False
End Sub
選択セルの背景色を調べてMsgBoxに表示する実験 Excel2000 VBA [Excel2000 VBA独習]
選択セルの背景色を調べてMsgBoxに表示する実験 Excel2000 VBA
Sub 選択セルの背景色を調べる()
Dim bgRGB, myR, myG, myB, bgColorI As Long
'アクティブセルの背景色を調べる
bgRGB = ActiveCell.Interior.Color
'アクティブセルの背景色番号を調べる
bgColorI = ActiveCell.Interior.ColorIndex
'RGBの値を求める
myR = bgRGB Mod 256
myG = Int(bgRGB / 256) Mod 256
myB = Int(bgRGB / 256 / 256)
'メッセージボックスに表示
MsgBox "選択セルの背景色のカラー番号は " & bgColorI _
& vbLf + vbLf & "選択セルの背景色は " & bgRGB & vbLf + vbLf & _
"選択セルの背景色RGBは " & "RGB(" & myR & "," & myG & "," & myB & ")"
End Sub
セルに付けた名前を利用してエンターキーを押した時の移動方向を決める実験 Excell2000 VBA [Excel2000 VBA独習]
セルに付けた名前を利用してエンターキーを押した時の移動方向を決める実験
動作は下の動画を参照
再生できない場合、ダウンロードは🎥こちら
セルに表示されている値がセルに付けた名前（名前は重複しないように、名前を変更する時は削除してから再設定）
セルに名前を付けるマクロ
Sub 選択範囲に名前を付ける()
Dim myName As String
Dim myR As Range
Dim i As Long
myName = InputBox("名前 始めの文字に必ず「右」「下」「移」をつける。")
For Each myR In Selection
i = i + 1 '名前がダブらないように番号を付加
myR.Name = myName & i 'セルに名前設定
myR = myName & i 'セルの値を設定（分かりやすくする為）
Next
End Sub
セルにつけた名前一覧を表示（どこかのサイトからコピー）
Sub ListAllNames()
Dim i As Integer
With ActiveWorkbook
For i = 1 To .Names.count
ActiveCell.Offset(i - 1, 0).Value = .Names(i).Name
ActiveCell.Offset(i - 1, 1).Value = .Names(i)
Next
End With
ActiveCell.EntireColumn.AutoFit
End Sub
セルの名前を調べる（名前が設定されていない時はエラーが発生）
複数のセルに同時に付けた名前のセルからは、このマクロでは名前の取得できない
Sub セルの名前を調べる()
On Error GoTo Er
MsgBox ActiveCell.Name.Name
Exit Sub
Er:
MsgBox "名前が設定されていません"
End Sub
ワークシートに設定するマクロ（シート名を右クリックして「コードの表示」をクリック）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cellName As String
Application.MoveAfterReturn = False '通常はセルの移動なし
On Error GoTo Er '名前が設定されてなければエラー
cellName = Left(ActiveCell.Name.Name, 1) '名前の始めの一文字（右、下、移）
'Debug.Print cellName
'名前が右ならエンターキーを押して右移動
If cellName = "右" Then Application.MoveAfterReturn = True: Application.MoveAfterReturnDirection = xlToRight: Exit Sub
'名前が下ならエンターキーを押して下移動
If cellName = "下" Then Application.MoveAfterReturn = True: Application.MoveAfterReturnDirection = xlDown: Exit Sub
'名前が移なら下に１左に４移動
If cellName = "移" Then Selection.Offset(1, -4).Select: Exit Sub
Exit Sub
Er:
Application.MoveAfterReturn = False
End Sub
ワークシートイベントの有効無効と数式保護風 Excel2000 VBA [Excel2000 VBA独習]
ワークシートイベントの有効無効
ワークシートイベントでイベントを無効にして編集、有効にしてワークシートイベントを有効にする。
Sub シートイベント有効無効()
’実行する度に有効→無効→有効
If Application.EnableEvents = False Then Application.EnableEvents = True Else Application.EnableEvents = False
End Sub
数式のあるセルを選択できなくする（数式保護）数式を選択すると右のセルに移動する。
VBEで保護したいシートを選択し（ダブルクリック）コードウインドウに記述
追記 セル結合に数式がある場合下のコードでは選択できてしまうので、If Selection.MergeCells Then ActiveCell.Offset(0, 1).Selectを追記すれば選択出来なくなる。(弊害もあるけど）
シートを作る時に、記入が必要なセルはセル結合しない設計が必要
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.HasFormula = True Then ActiveCell.Offset(0, 1).Select
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.HasFormula = True Then ActiveCell.Offset(0, 1).Select
If Selection.MergeCells Then ActiveCell.Offset(0, 1).Select
End Sub
数式のあるセルに罫線を引く
Sub 数式セルに罫線()
'
'inputboxで選択した範囲を調べ数式が設定されていれば罫線を引く
'
On Error GoTo Er 'inputboxでキャンセルボタンが押された時の処理のつもり
Dim myR, hani As Range
'InputBoxで選択範囲を取得
Set hani = Application.InputBox(Title:="数式のるセルに色つける", prompt:="範囲を選択してください!", Type:=8)
'選択範囲の数式のあるセルに罫線を引く
For Each myR In hani
If Left(myR.Formula, 1) = "=" Then
With myR.Borders
.Color = RGB(100, 100, 255)
.LineStyle = xlContinuous
.Weight = xlThin '標準 xlMedium(太線）
End With
End If
Next myR
Er:
Set hani = Nothing
End Sub
Excel2000 VBA バッチファイルを実行する実験 [Excel2000 VBA独習]
Excel2000 VBA バッチファイルを実行する実験
C:\Documents and Settings\FMV6000NU\Application Data\Microsoft\Excel フォルダをコピー(XCOPY)するバッチを作成し
バッチファイルをマクロで実行する実験（Excel.xlb と XLSTARTフォルダ内のファイル PERSONAL.xls など）
バッチファイルの作成
テキストエディター（メモ帳）を開き
xcopy "C:\Documents and Settings\FMV6000NU\Application Data\Microsoft\Excel" "D:\bk\office\Excelバックアップ\VBA" /s/y （xcopy 保存元 保存先 オプション）
のように記述し、ファイル名.bat で保存する
Sub BAT_2()
'batファイルを実行する（拡張子の関連付けで開く）
'xcopy "C:\Documents and Settings\FMV6000NU\Application Data\Microsoft\Excel"
'"D:\bk\office\Excelバックアップ\VBA" /s/y
' /Y 受け側の既存のファイルを上書きする前に確認のメッセージを表示しません｡
' /S 空の場合を除いて、ディレクトリとサブディレクトリをコピーします。
Dim WSH
Set WSH = CreateObject("Wscript.Shell")
WSH.Run "d:\bk\office\excel.bat" 'バッチファイル指定
Set WSH = Nothing
End Sub
以下のコードでは巧くいかなかった失敗例
Sub BAT()
Dim mybat As String
mybat = "d:\bk\office\excel.bat"
Shell "C:\WINNT\system32\cmd.exe " & mybat ', vbNormalFocus
End Sub
Sub メモ帳起動()
'メモ帳起動
Shell "C:\WINNT\system32\notepad.exe "
End Sub
Excel2000 VBA 範囲指定した範囲のみに入力出来るようにする実験 [Excel2000 VBA独習]
Excel2000 VBA 範囲指定した範囲のみに入力出来るようにする実験
数式が設定されているセルは選択できない。
Sub 選択範囲のみ入力出来るようする()
'原理
'シートの利用範囲を調べて、数式のあるセルを除いて数式化する
'選択範囲をInputBoxに入力し、範囲をNull化する
'シートのイベントで選択セルが数式なら右に移動する（シートイベント）
'つまりセルが数式なら選択出来ないようにする
Dim xRang, hani As Range
'シートの利用範囲を調べる
'ActiveSheet.UsedRange
For Each xRang In ActiveSheet.UsedRange
If InStr(xRang.Formula, "=") = 1 Then GoTo nextR
'数式化 test → =("test") null？(空白)は スペースに =(" ")
If xRang = "" Then
xRang = "=(" & Chr(34) & " " & Chr(34) & ")"
Else
xRang = "=(" & Chr(34) & xRang.Value & Chr(34) & ")"
End If
nextR:
Next xRang
'入力を許可する範囲を設定（複数選択可）
Set hani = Application.InputBox("入力を許可する範囲を選択してください。", Type:=8)
'範囲をNullに
For Each xRang In hani
xRang.Value = "入力可"
Next
Set hani = Nothing
'--------------------------------------------------------------
'以下のコードをシート名を右クリックし「コードの表示」を押して記入
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'If Target.HasFormula = True Then ActiveCell.Offset(0, 1).Select
'End Sub
'--------------------------------------------------------------
'MsgBox
MsgBox "終了しました。"
End Sub
Excel2000 VBA エンターキーを押してセルを設定した方向に移動選択する実験 [Excel2000 VBA独習]
Excel2000 VBA エンターキーを押してセルを設定した方向に移動選択する実験
再生できない場合、ダウンロードは🎥こちら
エンターキーを押して、セルをマクロで設定した方向に移動する
入力はできるが、出来ない作業もある（貼り付け）、いろいろ試さないと分からないけれど
A12に移動セルでは入力できない（選択できない）
A12など編集するには、シート名の所で右クリックして「コードの表示」を押し、VBEに移動するのでVBEのコードがウインドウでコード部分を選択して、コメント化（コメントブロックボタンで実行）する。
作業が終わったら、コメント化した部分を非コメントにする。
シート 名の所で右クリックし、「コード表示」をおしてVBEに移動、下記のコード記入
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
'通常は下移動
Application.MoveAfterReturn = True
Application.MoveAfterReturnDirection = xlDown
'A10:E10の範囲ではエンターキーを押して右移動
If Not Application.Intersect(ActiveCell, Range("A10:E10")) Is Nothing Then
Application.MoveAfterReturnDirection = xlToRight
End If
'F10:F12ではエンターキーを押して下移動
If Not Application.Intersect(ActiveCell, Range("F10:F12")) Is Nothing Then
Application.MoveAfterReturn = xlDown
End If
'B2:F9範囲ではエンターキーを押しての移動無効
If Not Application.Intersect(ActiveCell, Range("B2:F9")) Is Nothing Then
Application.MoveAfterReturn = False
End If
'F12が選択されたらA12を選択（移動）
If Not Application.Intersect(ActiveCell, Range("F12")) Is Nothing Then
Range("A12").Select
End If
'A14が選択されたらD14を選択（移動）
If Not Application.Intersect(ActiveCell, Range("A14")) Is Nothing Then
Range("D14").Select
End If
End Sub
数式が設定されてるセルは選択できない（右に移動）と設定方向に移動の組合せの実験
再生できない場合、ダウンロードは🎥こちら
A2セルは「 =("商品名") 」のように文字列だけど数式にする、他の文字列も同様に数式にする。
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
'数式が設定されているセルは選択できない（選択したら右に移動）
If Target.HasFormula = True Then ActiveCell.Offset(0, 1).Select
'移動方向設定
If Not Application.Intersect(ActiveCell, Range("B3:C5")) Is Nothing Then
Application.MoveAfterReturn = True
Application.MoveAfterReturnDirection = xlToRight
ElseIf Not Application.Intersect(ActiveCell, Range("E2:K6")) Is Nothing Then
Selection.Offset(1, -3).Select
Else
Application.MoveAfterReturn = False
End If
End Sub
選択範囲の文字列を数式化（選択できなくする為）
Sub セルの値を数式化()
'例 A1 TEST → =("TEST")
Dim xRan As Range
For Each xRan In Selection
'数式が設定されていればスキップ
'Debug.Print xRan.Formula, InStr(xRan.Formula, "=")
If InStr(xRan.Formula, "=") = 1 Then GoTo nextR
'数式化
xRan = "=(" & Chr(34) & xRan.Value & Chr(34) & ")"
nextR:
Next xRan
End Sub
Excel2000 VBA 数式の有るセルを選択出来ないようにする [Excel2000 VBA独習]
Excel2000 VBA 数式の有るセルを選択出来ないようにする
ネタ元は ttp://www.excel.studio-kazu.jp/mag2/backnumber/mm20040727.html
シートの保護とか、いろいろ試してきたけど、やっと目的の物が見つかった・・・・よかった！
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'数式の有るセルを選択したら右に移動（数式セルは選択できない）
'シートにこのマクロを設定
'シート名を右クリック「コードの表示」
'ttp://www.excel.studio-kazu.jp/mag2/backnumber/mm20040727.html
If Target.HasFormula = True Then ' Targetに数式があれば
ActiveCell.Offset(0, 1).Select ' ActiveCellの一つ右へ
End If
End Sub
選択範囲の文字列を数式化（選択できなくする為）
Sub セルの値を数式化()
'例 A1 TEST → =("TEST")
Dim xRan As Range
For Each xRan In Selection
'数式が設定されていればスキップ
'Debug.Print xRan.Formula, InStr(xRan.Formula, "=")
If InStr(xRan.Formula, "=") = 1 Then GoTo nextR
'数式化
xRan = "=(" & Chr(34) & xRan.Value & Chr(34) & ")"
nextR:
Next xRan
End Sub
Excel2000 VBA 上書き保存と世代バックアップ の実験 [Excel2000 VBA独習]
Excel2000 VBA 上書き保存と世代バックアップ の実験
マクロで上書き保存と世代バックアップ保存を同時に実行する
世代バックアップファイルには先頭に日時を挿入したファイル名にする
課題 パスワードが設定されているファイルだとエラーになるので？回避方法
Sub 上書き保存とバックアップ保存()
'自分用バックアップフォルダとカレントフォルダに保存
'バックアップ用フォルダにはファイル名の先頭に日時の文字を追加する
'世代間バックアップ風 例（2011-8-25 木 15-01-15.test.xls）
'
Dim file_name, sub_name As String
Dim file_1, file_2 As String
On Error GoTo Er
'上書き保存の確認ダイアログを表示させない
Application.DisplayAlerts = False
'アクティブブックのファイル名を取得
file_name = ActiveWorkbook.Name
'上書き保存とバックアップフォルダに同名で保存
ActiveWorkbook.SaveAs fileName:="D:\bk\office\Excelバックアップ\" & file_name
ActiveWorkbook.SaveAs fileName:="D:\bk\office\" & file_name
'バックアップフォルダに保存したファイル名を変える（実験を兼ねて）
file_1 = "D:\bk\office\Excelバックアップ\" & file_name
'日時をファイル名の先頭につける
sub_name = Replace(Now, "/", "-")
sub_name = Replace(sub_name, ":", "-")
sub_name = Replace(sub_name, "(", "")
sub_name = Replace(sub_name, ")", "")
file_2 = "D:\bk\office\Excelバックアップ\" & sub_name & "." & file_name
'フィル名の変更
Name file_1 As file_2
'ダイアログを表示するようにする
Application.DisplayAlerts = True
'---------保存の確認用-------------------------------------------
'Excelバックアップ フォルダを開く
' Dim myFolder As String
'フォルダの設定
'myFolder = ThisWorkbook.Path
' myFolder = "D:\bk\office\Excelバックアップ"
'エクスプローラの起動（Windows2000 C:\WINNT WindowsXP C:\Windows)
' Shell "C:\WINNT\Explorer.exe " & myFolder, vbNormalFocus
'----------------------------------------------------------------
'終了
Exit Sub
'エラー処理(パスワードの有るブックファイルはエラーになる？エラーの回避方法がわからん)
Er:
MsgBox "エラー番号 " & Err.Number & vbCrLf + vbCrLf & Err.Description
End Sub
バックアップファイルの削除 実験
Sub バックアップファイル削除3()
'
'ファイルを削除 確認メッセージあり
'７日以上前のファイルを削除する
'
Dim buf, file_name, file_date, MB As String
Dim cnt As Long
Const Path As String = "d:\bk\office\Excelバックアップ\"
buf = Dir(Path & "*.xls")
Do While buf <> ""
file_name = buf
file_date = FileDateTime(Path & buf)
'Debug.Print DateDiff("d", file_date, Now)
'ファイルが７日以上前なら削除
If DateDiff("d", file_date, Now) > 7 Then
MB = MsgBox(file_name & "削除しますか？", vbYesNo)
Select Case MB
Case vbYes
Kill Path & file_name
Case vbNo
End Select
End If
buf = Dir()
Loop
MsgBox "該当する削除対象ファイルが有りません。" & vbCrLf & "終了します。"
End Sub
Sub バックアップファイル削除()
'
'ファイルを削除するので動作テストをする事
'７日以上前のファイルを削除する
'
Dim buf, file_name, file_date As String
Dim cnt, re As Long
Dim SH As SHFILEOPSTRUCT
Const Path As String = "d:\bk\office\Excelバックアップ\"
buf = Dir(Path & "*.xls")
Do While buf <> ""
cnt = cnt + 1
file_name = buf
file_date = FileDateTime(Path & buf)
'Debug.Print DateDiff("d", d, Now)
'ファイルが７日以上前なら削除
If DateDiff("d", file_date, Now) > -1 Then
With SH
'.hwnd = Application.hwnd
.wFunc = FO_DELETE
.pFrom = Path & buf
.fFlags = FOF_ALLOWUNDO
End With
re = SHFileOperation(SH)
If re <> 0 Then MsgBox "削除に失敗しました", vbExclamation
End If
buf = Dir()
Loop
End Sub
Excel2000 VBA エクスプローラを起動する 実験 [Excel2000 VBA独習]
Excel2000 VBA エクスプローラを起動する 実験
Sub フォルダを開く()
'
'
Dim myFolder As String
'フォルダの設定
'myFolder = ThisWorkbook.Path
myFolder = "D:\bk\office\Excelバックアップ"
'エクスプローラの起動（Windows2000 C:\WINNT WindowsXP C:\Windows)
Shell "C:\WINNT\Explorer.exe " & myFolder, vbNormalFocus
End Sub
Excel2000 VBA セルの値によって右側に矢印アイコンを表示する実験 [Excel2000 VBA独習]
Excel2000 VBA セルの値によって右側に矢印アイコンを表示する実験
Sub test2()
'数値を調べてゼロ以上なら↑アイコンを表示
'
Dim xRange As Range
'選択範囲から１つずつセルを調べる
For Each xRange In Selection
If xRange > 0 Then
xRange.Offset(0, 1).Activate
Call face(38)
End If
If xRange = 0 Then
xRange.Offset(0, 1).Activate
Call face(39)
End If
If xRange < 0 Then
xRange.Offset(0, 1).Activate
Call face(40)
End If
Next xRange
End Sub
Function face(num As Integer)
'face(num)で受け取ったFaceIDをセルに表示
'
Dim myCB As Variant
'コマンドバーの作成と表示
Set myCB = CommandBars.Add(Name:="FaceID")
myCB.Visible = True
'Face（アイコン）の設定とコピー
With myCB.Controls.Add
.FaceId = num
.CopyFace
End With
'シートに貼り付け
'ActiveSheet.Select
ActiveSheet.PasteSpecial Format:="ビットマップ", Link:=False, DisplayAsIcon:=False
'作成したコマンドバーの削除
myCB.Delete
Set myCB = Nothing
End Function
Excel2000 VBA セルの数式をコメント欄に表示するの実験 [Excel2000 VBA独習]
Excel2000 VBA セルの数式をコメント欄に表示するの実験
Sub コメント欄にセルの数式を表示()
'
'実験なので、対象は選択セルのみ
'
Dim ComTxt, FormulaTxt As String
ActiveCell.Select
'数式の文字列
FormulaTxt = "セルの数式" & Chr(10) & ActiveCell.Formula
'数式が設定されてなければ終了
If FormulaTxtActiveCell.Formula = "" Then MsgBox "数式が設定されてません。": Exit Sub
'選択セルにコメントが設定されているか調べて、設定されていれば
'コメントに数式文字列を追加する
If TypeName(ActiveCell.Comment) = "Comment" Then
ComTxt = ActiveCell.Comment.Text '現在のコメントテキスト
'コメント設定
ActiveCell.Comment.Text Text:=ComTxt & Chr(10) + Chr(10) & FormulaTxt
Else
'新たにコメント作成
With ActiveCell.AddComment
.Text FormulaTxt
'.Visible = True
End With
End If
End Sub
選択範囲の数式をコメント欄に記入
Sub コメント欄にセルの数式を表示2()
'
'事前にドラッグしてセル範囲を選択する
'
Dim ComTxt, FormulaTxt As String
Dim contR As Range
'選択範囲
For Each contR In Selection
contR.Activate
'数式の文字列
FormulaTxt = "セルの数式" & Chr(10) & ActiveCell.Formula
'数式が設定されてなければ次
If ActiveCell.Formula = "" Then GoTo next_each
'選択セルにコメントが設定されているか調べて、設定されていれば
'コメントに数式文字列を追加する
If TypeName(ActiveCell.Comment) = "Comment" Then
ComTxt = ActiveCell.Comment.Text '現在のコメントテキスト
'コメントに同じ数式があれば書き足さない
If InStr(ComTxt, ActiveCell.Formula) > 1 Then GoTo next_each
'コメント設定
ActiveCell.Comment.Text Text:=ComTxt & Chr(10) & FormulaTxt
Else
'新たにコメント作成
With ActiveCell.AddComment
.Text FormulaTxt
'.Visible = True
End With
End If
next_each:
Next contR
End Sub
Excel2000 VBA アクティブシートのグラフ数とグラフ名を調べる 実験 [Excel2000 VBA独習]
Excel2000 VBA アクティブシートのグラフ数とグラフ名を調べる 実験
Sub チャートの数と名前()
'アクティブシートのグラフ数と名前
'ttp://www.moug.net/tech/exvba/0020001.htm
Dim intChart, i As Integer
Dim ChaｒName(), strMB As String
'アクティブシートのChartObjects数
intChart = ActiveSheet.ChartObjects.count
'配列の個数設定
ReDim CharName(intChart)
'ChartObjects名取得
For i = 1 To intChart
CharName(i) = ActiveSheet.ChartObjects(i).Name
Next i
'MSGBOXに表示
'表示用文字列を作成
For i = 1 To intChart
strMB = strMB & CharName(i) & vbCrLf + vbCrLf
Next i
MsgBox "シート名= " & ActiveSheet.Name & vbCrLf & "グラフ数= " & intChart & vbCrLf + vbCrLf & "== グラフ名 ==" & vbCrLf & vbCrLf & strMB
End Sub
Sub 縦線の表示非表示()
Dim GraLine_V As Object
'開いているシートのグラフをアクティブにする
ActiveSheet.ChartObjects("Chart 1").Activate
'グラフのx項目目盛線（主縦線）が表示されていれば非表示でなければ表示する
Set GraLine_V = ActiveChart.Axes(xlCategory)
If GraLine_V.HasMajorGridlines = True Then
GraLine_V.HasMajorGridlines = False
Else:
GraLine_V.HasMajorGridlines = True
End If
Set GraLine_V = Nothing
End Sub
マクロの記録でグラフオプションの目盛線を設定して作成されたコード部分
With ActiveChart.Axes(xlCategory)
.HasMajorGridlines = True '主縦線
.HasMinorGridlines = False '副縦線
End With
With ActiveChart.Axes(xlValue)
.HasMajorGridlines = True '主横線
.HasMinorGridlines = False '副横線
End With
グラフの名前設定
Sub chartNmae()
'ChartObjectの名前を設定する
'
On Error GoTo Er '該当するchartが無ければ
'名前設定
ActiveSheet.ChartObjects("AAA").name = "chrat 1"
'== ActiveSheet.ChartObjects(番号か"名前").name = "名前" ==
Exit Sub
Er:
MsgBox "該当するChartObjectが有りません。"
End Sub
Excel2000 VBA Face（アイコン）の番号を指定してセルに表示する実験 [Excel2000 VBA独習]
Excel2000 VBA Face（アイコン）の番号を指定してセルに表示する実験
Face番号一覧は、http://telstar.blog.so-net.ne.jp/2011-08-14 の記事参照
Sub FaceID番号を指定してセルに表示()
'
'inputboxにFaxeID番号を入力し、セルに表示する
'
Dim NoFID As Integer
Dim myCB As CommandBar
'エラーが発生したら
On Error GoTo Er
'inputboxでFaceID番号取得(1-3518)
NoFID = Application.InputBox("FaｃeID番号を入力してください。(1-3518)", Type:=1)
'取得FaceID番号が1-3518の範囲外なら終了
If NoFID < 1 Or NoFID > 3518 Then
MsgBox "FaceIDの番号が(1-3518)の範囲外です。" & vbCrLf + vbCrLf & "終了します。"
Exit Sub
End If
'コマンドバーの作成と表示
Set myCB = CommandBars.Add(Name:="FaceID")
myCB.Visible = True
'Face（アイコン）の設定とコピー
With myCB.Controls.Add
.FaceId = NoFID
.CopyFace
End With
'シートに貼り付け
'ActiveSheet.Select
ActiveSheet.PasteSpecial Format:="ビットマップ", Link:=False, DisplayAsIcon:=False
GoTo M_End
'エラー処理らしきもの
Er:
MsgBox "シートに貼り付け出来ませんでした。" & vbCrLf + vbCrLf & "Ctrl+Vで貼り付けてください。"
'終了処理
M_End:
'作成したコマンドバーの削除
myCB.Delete
Set myCB = Nothing
End Sub
Excel2000 VBA URLを既定のブラウザで開く [Excel2000 VBA独習]
Excel2000 VBA URLを既定のブラウザで開く
利用方法
いつも利用するVBAの解説サイトURLを設定しマクロボタンに割り当てる（Myヘルプみたいな感じ）
マクロボタンにハイパーリンクを設定すれば同じなんですけど・・・・
Sub openURL()
'Windows Scripting Hostを利用する
'既定のブラウザでURLを開く
'参考サイト ttp://officetanaka.net/excel/vba/tips/tips42.htm
Dim WSH
Dim URL As String
Set WSH = CreateObject("Wscript.Shell")
URL = "http://technet.microsoft.com/ja-jp/library/cc985270.aspx"
WSH.Run URL, 3
Set WSH = Nothing
End Sub
Excel2000 VBA エンターキーを押して右、下移動、無効、マクロ用コマンドバー作成 [Excel2000 VBA独習]
Excel2000 VBA エンターキーを押して右、下、無効、マクロ用コマンドバー作成
マクロを実行して作成されたコマンドバーをツールバーにドラッグ＆ドロップする。
Sub コマンドバーカーソル移動作成()
'コマンドバーを作成して
'エンターキーを押して下移動、右移動、移動なしのマクロボタンを追加作成
'コマンドバーをツールバーのドラッグ＆ドロップする
Dim Mname As String
Dim barName As Variant
Dim myBar As CommandBar
'--- コマンドバーを作成(コマンドバー名=カーソル移動) ---
Mname = "カーソル移動"
'ツールバーに「カーソル移動」が有るか調べ無ければ作成
For Each barName In CommandBars
'Debug.Print barName.Name
If barName.Name = Mname Then barName.Delete '"カーソル移動"を削除する
Next
'新しいコマンドバーを作成
Set myBar = CommandBars.Add(Name:=Mname)
myBar.Visible = True
'オリジナルのコマンド作成
With myBar.Controls.Add
.Caption = "右移動"
.FaceId = 39
.OnAction = "cursor_right" 'エンターキーを押して右移動
End With
With myBar.Controls.Add
.Caption = "下移動"
.FaceId = 40
.OnAction = "cursor_down" 'エンターキーを押して下移動
End With
With myBar.Controls.Add
.Caption = "移動なし"
.FaceId = 330
.OnAction = "move_after_false" '移動なし
End With
' With myBar.Controls.Add
' .FaceId =
' .OnAction = "" '追加用
' End With
' With myBar.Controls.Add
' .FaceId =
' .OnAction = "" '追加用
' End With
Set myBar = Nothing
End Sub
Sub cursor_right()
'
' enter で右移動
'
'エンターキーを押して右移動
Application.MoveAfterReturn = True
Application.MoveAfterReturnDirection = xlToRight
End Sub
Sub cursor_down()
'
' enter で下移動
'
'エンターキーを押して下移動
Application.MoveAfterReturn = True
Application.MoveAfterReturnDirection = xlDown
End Sub
Sub move_after_false()
'
' enter で移動無効
'
'エンターキーを押して移動を無効
Application.MoveAfterReturn = False
End Sub