ホリスティックリンパエステサロンＧＯＬＤのホームページ
http://www.baycom.zaq.ne.jp/bgcnb202/index.html
コーヤンのホームページ
＜プロテクト＞
'************************************************************
'シートのプロテクト
ActiveSheet.Protect
'シートのプロテクトの解除
ActiveSheet.Unprotect
'************************************************************
＜画面の制御＞
'************************************************************
'画面の動きを止める
Application.ScreenUpdating = False
'画面の動きを再開する
Application.ScreenUpdating = True
'************************************************************
＜オートフィルター＞
'************************************************************
'オートフィルターがかかっているかどうか判断する
If ActiveSheet.AutoFilterMode = True Then
'オートフィルターがかかっています
MsgBox "filter on"
'オートフィルターの解除
Selection.AutoFilter
Else
'オートフィルターがかかっていません
MsgBox "filter off"
End If
'************************************************************
＜カーソルの移動＞
'************************************************************
'カーソルの移動方向を変更する
Application.MoveAfterReturnDirection = xlDown 'カーソル移動を下方向へ
Application.MoveAfterReturnDirection = xlToRight 'カーソル移動を右方向へ
'カレントセルを入力されている最後の行へ移動させる（上から下へ）
Range("A1").Select
Selection.End(xlDown).Select
'カレントセルを入力されている最後の行へ移動させる（下から上へ）
Range("A10000").Select
Selection.End(xlUp).Select
'オフセット命令(１行下へ）
' (行、列)
Selection.Offset(1, 0).Select
'オフセット命令(１列右へ）
(行、列)
Selection.Offset(0, 1).Select
'************************************************************
＜テキストボックス・コンボボックス＞
'************************************************************
'テキストボックス１の内容をＡ１のセルに転記する
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Range("A1") = TextBox1.Text
End Sub
'************************************************************
'Ａ２のセルの内容をテキストボックス１に転記する
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
TextBox2.Text = Range("A2")
End Sub
'************************************************************
'コマンドボタンからテキストボックスへフォーカスを移動する際に、
'テキストボックスの文字を全部選択状態にするには、コマンドボタン
'をクリックした時に次の命令を実行する
SendKeys "{TAB}"
'************************************************************
Private Sub UserForm_Initialize()
'コンボボックスのリストに列名をセットする
ComboBoxリスト.AddItem Range("D1")
ComboBoxリスト.AddItem Range("E1")
ComboBoxリスト.AddItem Range("F1")
ComboBoxリスト.AddItem Range("G1")
ComboBoxリスト.AddItem Range("H1")
ComboBoxリスト.AddItem Range("I1")
ComboBoxリスト.AddItem Range("J1")
End Sub
'************************************************************
＜検 索＞
'************************************************************
'Ｌ６のセルに 前 の字があるかどうかを調べ、あれば、メッセージを表示
Range("L6").Select
If Range("L6") Like "*前*" Then
MsgBox "「前」見っけ"
End If
'************************************************************
Dim sGyo As Integer '検索して見つかった行を記憶する変数
Dim wRowL As Integer '検索範囲の最後の行数を記憶する変数
Worksheets("リスト").Activate
wRowL = 10000
sGyo = wRowL
With Worksheets("リスト").Range("A2:A" & wRowL & "")
'番号で検索する。
Set c = .Find(Txt番号.Text, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
sGyo = c.Row
Else
GoTo FindError
End If
End With
FindError:
'エラー処理
'************************************************************
＜エラー処理＞
'************************************************************
'エラーが発生した時の処理
On Error GoTo err_01
'オフセット命令(１行上へ）
(行、列)
Selection.Offset(-1, 0).Select
'エラー（この場合、上へ１行けないとき）の処理
err_01:
Exit Sub
'************************************************************
＜セル選択・値の取得・文字列変換＞
'************************************************************
'人数の受け入れ
ninzu = InputBox("人数を入力してください。", "人数の入力")
'************************************************************
'メッセージボックスを表示して OK、キャンセルの判断を求める
w_yn = MsgBox(" すべてクリアします。よろしいですか？" & Chr(13) _
& " 復活できませんので、念のため保存をしておいてください。", vbOKCancel, " クリア")
'w_yn=1:OK, =2:Cancel
'キャンセルを選んだとき
If w_yn = 2 Then
Exit Sub
End If
'メッセージボックスを表示してイエス、ノーの判断を求める
Sub Macro2()
Dim w_yn As Integer
ActiveWindow.SelectedSheets.PrintPreview
w_yn = MsgBox("印字しますか？", vbYesNo, "印字")
If w_yn = 6 Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End If
End Sub
'メッセージボックスを表示してイエス、ノー、キャンセルの判断を求める
w_yn = MsgBox("削除しますか？", vbYesNoCancel, "重複データの削除")
'w_yn=6:Yes, =7:No, =2:Cancel
'キャンセルを選んだとき
If w_yn = 2 Then
Exit Sub
End If
'Yes を選んだとき
If w_yn = 6 Then
Selection.Delete Shift:=xlUp
End If
'************************************************************
'列と行を数字で指定してセルを選択する
' 行 列
Cells(wRow, wCol).Select
'複数セルの選択
Range(Cells(5, ActiveCell.Column), Cells(10000, ActiveCell.Column)).Select
'************************************************************
'数値の入っているセルだけを選択する
Selection.SpecialCells(xlCellTypeConstants, 1).Select
'************************************************************
'カレントセルの行、列を取得し、そのセルの内容を表示する
'現在の行を記憶する変数
Dim w_Gyo As Long
'現在の列を記憶する変数
Dim w_Retu As Integer
'数字をアルファベットへ変換するための変数
Dim a_Retu As String
'現在の行を記憶する（１行目＝１から始まる数字）
w_Gyo = ActiveCell.Row
'現在の列を記憶する（Ａ列＝１から始まる数字）
w_Retu = ActiveCell.Column
'記憶した行、列を表示する
MsgBox "現在の行は： " & w_Gyo
MsgBox "現在の列は： " & w_Retu
'************************************************************
'w_Retuをアルファベットへ変換する（ Chr(65) は A を示す）
a_Retu = Chr(w_Retu + 64)
' ( 列 行 )
MsgBox "現在のセルの内容は： " & Range(a_Retu & w_Gyo & "").Text
'************************************************************
カラム数をＡＢＣの文字へ変換する
Select Case ActiveCell.Column
Case Is < 27
retsumoji = Chr(ActiveCell.Column + 64)
Case Is < 53
retsumoji = "A" & Chr(ActiveCell.Column + 64 - 26)
Case Is < 79
retsumoji = "B" & Chr(ActiveCell.Column + 64 - 52)
Case Is < 105
retsumoji = "C" & Chr(ActiveCell.Column + 64 - 78)
End Select
'アクティブセル番地をＡ１形式で表示する
MsgBox ActiveCell.Address(xlA1)
'アクティブセル番地のＡ１形式から列番号のみを抽出する
Dim w_ACol As String
w_ACol = Replace(Left(ActiveCell.Address(xlA1), 3), "$", "")
'************************************************************
'文書番号と発送日を入力させる
Dim aa As String
Dim bb As Date
aa = InputBox("文書番号を入力してください。", "文書番号")
bb = InputBox("発送日を入力してください。", "発送日")
MsgBox "第 " & aa & " 号"
MsgBox Format(bb, "ggge年mm月dd日")
'************************************************************
'日付の設定
'選択したセルの表示形式を「月曜日」のように設定
Range("A1").Select
Selection.NumberFormatLocal = "aaaa"
'選択したセルの表示形式を「月」のように設定
Range("A2").Select
Selection.NumberFormatLocal = "aaa"
'選択したセルの表示形式を「(月)」のように設定
Range("A3").Select
Selection.NumberFormatLocal = "(aaa)"
'選択したセルの表示形式を「monday」のように設定
Range("A4").Select
Selection.NumberFormatLocal = "dddd"
'選択したセルの表示形式を「mon」のように設定
Range("A5").Select
Selection.NumberFormatLocal = "ddd"
'選択したセルの表示形式を「平成17年04月11日(月)」のように設定
Range("A6").Select
Selection.NumberFormatLocal = "ggge年mm月dd日(aaa)"
'選択したセルの表示形式を「平成17年4月4日(月)」のように設定
Range("A7").Select
Selection.NumberFormatLocal = "gge年m月d日(aaa)"
'選択したセルの表示形式を「H17.4.4(月)」のように設定
Range("A8").Select
Selection.NumberFormatLocal = "ge.m.d(aaa)"
'フォーマット関数を使って
'選択したセルの表示形式を「平成17年04月11日(月)」のように設定
Range("A9") = Format(DateValue("2005/4/11"), "ggge年mm月dd日(aaa)")
'************************************************************
'キー入力した内容を送る
Private Sub Report_Activate()
SendKeys "%vz{down}{down}{down}{enter}"
End Sub
'************************************************************
'セルの背景色を変える
Range("A1").Select
Selection.Interior.ColorIndex = xlNone '色無しにする
Selection.Interior.ColorIndex = 3 '赤色にする
'************************************************************
'テキストボックスの内容をカンマ付数字で表示する
TextBox1.Text = Format(TextBox1.Text, "#,##0")
'************************************************************
'テキストボックスの内容を３桁づつスペースで区分けして表示する
TextBox1.Text = Format(TextBox1.Text, "### ### ### ###")
'************************************************************
'マイナス表示を△表示に変換する
Range("A1") = Replace("- 123 456", "-", "△ ", 1, , vbTextCompare)
'************************************************************
'「"」を数式の中に入れるには
'A1セルに 「=IF(B1="","a",C1)」 という式を入れたい
Range("A1") = "=IF(B1="""",""a"",C1)"
' A1 のセルに「="大阪府"&C1」と数式を入れたい。「"」は Chr(34) で表せる
'下記の例で、 C1 セルに「大阪市」と入っており、
'実行結果は、 A1 のセルに「大阪府大阪市」と表示される。
Range("A1") = "=" & Chr(34) & "大阪府" & Chr(34) & "&C1"
'************************************************************
'セルへ数式を入れるサンプル
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Sheets("送付書").Select
Range("J15") = "=VLOOKUP(J1,支店リスト!$A$5:$O$416,12,0)"
Range("J16").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(R[-15]C,支店リスト!R5C1:R416C15,15,0)"
Range("A26").Select
ActiveCell.FormulaR1C1 = "=" & Chr(34) & "本店 " & Chr(34) & _
"&VLOOKUP(R[-25]C[9],支店リスト!R5C1:R416C12,3,0)"
Sheets("支店リスト").Select
Application.ScreenUpdating = True
End Sub
'************************************************************
'ほかのBookのセルから値を転記する
Sheets("Sheet1").Range("A1") = _
Workbooks("Book2.xls").Sheets("Sheet1").Range("A1")
'************************************************************
小数点以下を切り上げる
Dim pNum As Integer
Sheets("Sheet1").Select
wCol = ActiveCell.Row
pNum = Round((wCol - 2) / 40, 0)
If pNum < ((wCol - 2) / 40) Then
pNum = pNum + 1
End If
'************************************************************
小数点以下を切り上げる（その２） ワークシート関数を使用
Dim rndUp As Integer
'小数点以下を切り上げる
rndUp = Application.WorksheetFunction.RoundUp(1.1, 0)
MsgBox rndUp
'************************************************************
Wait メソッドの使用例
次の使用例は、実行中のマクロを当日の午後 6 時 23 分まで停止します。
Application.Wait "18:23:00"
次の使用例は、実行中のマクロを約 10 秒間停止します。
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 10
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime
次の使用例は、10 秒を過ぎるとメッセージを表示します。
If Application.Wait(Now + TimeValue("0:00:10")) Then
MsgBox "時間が過ぎました。"
End If
'************************************************************
'配列関数で支店名を入れる
Dim w_Jimmei As Variant
w_Jimmei = Array(, "北海道", , "青 森", "宮 城", , , , , , "東 京", _
"神奈川", , , , "静 岡", "愛 知", "京 都", "大 阪", _
"兵 庫", "福 岡", "鹿児島")
Range("F" & w_Row & "") = w_Jimmei(Range("B" & w_Row & ""))
'************************************************************
＜ファイル操作＞
'************************************************************
'ファイル名を変更して保存する
Dim wrkName As String
wrkName = ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:="Y:\BACKUP\担当用\" & "次" & wrkName, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
wrkName = ActiveWorkbook.Name
MsgBox "ファイル名を " & wrkName & " に変更し、保存しました。" _
& Chr(13) & "後で、ファイル名を適切な名称に変更してください。", _
, "ファイル名の変更"
'************************************************************
'ファイルを保存しないでエクセルを強制終了する
Application.DisplayAlerts = False 'ファイルを保存しない
Application.Quit 'エクセルの終了
'************************************************************
'ファイルを保存後エクセルを強制終了する
'保存し終了
ActiveWorkbook.Save
Application.Quit
'************************************************************
'ファイルを開くダイアログを開く
Application.GetOpenFilename "Excelファイル (*.xls), *.xls", , , , false
'
'************************************************************