| span class="red12">ユーザーフォームを表示させるアドインの設定指示
Private Sub Workbook_Open()
SAA01セット <---- アドインの表示
End Sub
-------------------- ここから Uform100のコード ---------------------
[文字変換]ボタンクリックで「文字書換」を実行する。
Private Sub CommandButton1_Click()
文字書換
End Sub
-----------------------------------------------------------------------
[セル設定]ボタンクリックで「範囲をドラッグして指定」を実行する
Private Sub CommandButton10_Click()
範囲をドラッグして指定
End Sub
-----------------------------------------------------------------------
[保護解除]ボタンクリックで「保護解除」を実行する
Private Sub CommandButton11_Click()
保護解除
End Sub
-----------------------------------------------------------------------
[リストデータ設定解除]ボタンクリックで「リストデータ設定解除」を実行する
Private Sub CommandButton12_Click()
リストデータ設定解除
End Sub
-----------------------------------------------------------------------
[セルの色消去]ボタンクリックで「Cell_Color_off」を実行する
Private Sub CommandButton13_Click()
' [Locked_Cell_get]で保護のかかったセルに色を付けたのを消去する
Cell_Color_off
End Sub
-----------------------------------------------------------------------
[保護のかかったセルの色付け]ボタンクリックで
「Locked_Cell_get」を実行する。
Private Sub CommandButton14_Click()
' 保護のかかったセルに色を付ける。
Locked_Cell_get
End Sub
-----------------------------------------------------------------------
[スペース削除]ボタンクリックで「Space」を実行する。
Private Sub CommandButton2_Click()
Space
End Sub
-----------------------------------------------------------------------
[リストデータ設定]ボタンクリックで「リストデータ設定」を実行する。
Private Sub CommandButton4_Click()
リストデータ設定
End Sub
-----------------------------------------------------------------------
[文字列->>数値]ボタンクリックで「変換開始数字」を実行する。
Private Sub CommandButton5_Click()
変換開始数字
End Sub
-----------------------------------------------------------------------
[数値->>文字列]ボタンクリックで「変換開始文字」を実行する。
Private Sub CommandButton6_Click()
変換開始文字
End Sub
-----------------------------------------------------------------------
[不要メニュー消去]ボタンクリックで不要メニュー消去し、
ユーザーフォームを表示させるアドインの表示指示を実行する。
Private Sub CommandButton7_Click()
CommandBars("Worksheet Menu Bar").Reset
SAA01セット
End Sub
-----------------------------------------------------------------------
[計算式セル色付]ボタンクリックで「計算式セル色付」を実行する。
Private Sub CommandButton8_Click()
計算式セル色付
End Sub
-----------------------------------------------------------------------
[計算式セル色解除]ボタンクリックで「計算式セル色解除」を実行する。
Private Sub CommandButton9_Click()
計算式セル色解除
End Sub
-----------------------------------------------------------------------
ユーザーフォームUForm100を初期化するする。
Private Sub UserForm_Initialize()
UForm100.OptionButton1 = True <---- [選んだ範囲を保護]の
End Sub オプションボタンをONする。
------------------- ここから Uform101のコード ----------------------
[保護するセルの追加設定]ボタンクリックでドラックした範囲の
情報をマクロの表紙に書き込むサブルーチン。
Private Sub CommandButton1_Click()
Dim Hogo_Range As Range
N = Workbooks(AAname).Sheets(BBname).Cells(5, 1).Value
' 保護する範囲の区別情報
NN = Workbooks(AAname).Sheets(BBname).Cells(6, 1).Value
保護する範囲の区別を判定して、メッセージを変える。
If NN = 1 Then
On Error Resume Next <-- エラーの時は、スキップさせる指定
セル範囲を入力させるメッセージを表示する。Type:=8 でセル範囲の指定
Set Hogo_Range = Application.
InputBox(prompt:="保護する範囲をドラッグしてください", Type:=8)
On Error GoTo 0 <-- エラー処理の指定解除
If Hogo_Range Is Nothing Then Exit Sub <-- キャンセル時の強制終了
Else
On Error Resume Next
Set Hogo_Range = Application.
InputBox(prompt:="保護しない範囲をドラッグしてください", Type:=8)
On Error GoTo 0
If Hogo_Range Is Nothing Then Exit Sub ' キャンセル時の処理
End If
' H25.06.22 変更・追加
' Address(False, False)でレンジデータが取得できます。
CCC = Hogo_Range.Address(False, False)
' レンジデータの区切り文字( : )の位置を取得します。
M = InStr(1, CCC, ":")
' ドラッグ範囲の始まり位置を取得します。
AAA = Mid(CCC, 1, M - 1)
' レンジデータの文字数を取得します。
NN = Len(CCC)
' ドラッグ範囲の終わり位置を取得します。
BBB = Mid(CCC, M + 1, NN - M)
' 変数AAAとBBBにドラッグ範囲の始まりと終わり位置がレンジデータと
' して取得できます。
N = Workbooks(AAname).Sheets(BBname).Cells(5, 1).Value
ドラック範囲のデータを「マクロの表紙」のセル位置(N,12)と(N,13)に書込む
マクロの表紙にドラック範囲のデータを保存
Workbooks(AAname).Sheets(BBname).Cells(N + 1, 12).Value = AAA
Workbooks(AAname).Sheets(BBname).Cells(N + 1, 13).Value = BBB
範囲データのカウンタを +1 する。
Workbooks(AAname).Sheets(BBname).Cells(5, 1).Value = N + 1
UForm101.Show vbModeless <-- ユーザーフォーム UForm101 を表示
End Sub
-----------------------------------------------------------------------
[セルの保護設定]ボタンクリックで計算式ロックを実行する。
Private Sub CommandButton2_Click()
計算式ロック
End Sub
--------------------- ここから module1 コード ---------------------
Public x, y, x1, y1, x2, y2, x3, x4, yy1, yy2, II As Long
Public mm, N, N1, N2, N3, N4, NN, CC, iii, Bcnt, CNT, Scnt As Single
Public M, M1, M2, M3, M4, HT, HF, FF As Single
Public CL_Range, C_Range, CL As Variant
' Excelマクロブック名
Public Const AAname As String = "セル操作マクロ.xlsm"
Public Const BBname As String = "表紙" <---- Excelマクロシート名
Public B1, S1, SS As String
Public ABname, ASname, folda As String
Public AAA, BBB, CCC, DirA, DirB, Fname, Rname, RBname As String
Public Fname1, Fname2, Fname3, B1name, S1name As String
Dim myFname, Sname, Gname, Tname, dir1, HH As String
Dim CL_Range, C_Range As Variant
-----------------------------------------------------------------------
Excelブックがオープンした時に実行するサブルーチン
Sub auto_open()
'----------------------------------------------------
' Excel 起動時にメニューバーをアドインに移動させる処理
'----------------------------------------------------
この様にしないといつまでも Excelブックがオープンしない
' タイムディレー処理 直ぐに、サブルーチン AddIN を実行させる
Application.OnTime Now + TimeValue("00:00:00"), "AddIN"
End Sub
-----------------------------------------------------------------------
メニューバーを「アドイン」に移動させる処理
Sub AddIN()
Sheets(BBname).Select <---- 所定のシートを表示させる
N = Val(Application.Version) <---- Excelのバージョンを取得する
Excelのバージョンの"2000 ; 9","2002 ; 10","2003 ; 11"時は、何もしない
If N = 9 Or N = 10 Or N = 11 Then Exit Sub
Excelのバージョンの"2007 ; 12","2010 ; 14","2013 ; 15","2016 ; _
' 16"時は、アドインに移動
' [ALT]-->[X]-->[ALT]のキー入力を実行
Application.SendKeys ("%X%")
End Sub
-----------------------------------------------------------------------
ユーザーフォームを表示させるアドインの表示指示
Sub SAA01セット()
Dim Mycontrol As CommandBarControl
Dim mysubmenu As CommandBarControl
Set Mycontrol = CommandBars("Worksheet Menu Bar"). _
Controls.Add(msoControlPopup)
Mycontrol.Caption = "(■)"
Mycontrol.OnAction = "UForm1表示"
End Sub
-----------------------------------------------------------------------
ユーザーフォームを表示する vbModelessを付けると、ユーザーフォームを
マウスで自由に移動できます。
Sub UForm1表示()
UForm100.Show vbModeless
End Sub
-----------------------------------------------------------------------
ユーザーフォームを表示させるアドインの消去指示
Sub SAA02リセット()
CommandBars("Worksheet Menu Bar").Controls("(■)").Delete
End Sub
-----------------------------------------------------------------------
ドラックしたセル内の文字列から、半角･全角のスペースを削除する。
Sub Space()
' スペース削除
AAA = " " <---- 半角のスペースを指定
BBB = "" <---- 文字なしを指定
ドラックされたセル範囲の半角スペースを削除する
Selection.Replace What:=AAA, Replacement:=BBB, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
AAA = " " <---- 全角のスペースを指定
ドラックされたセル範囲の全角スペースを削除する
Selection.Replace What:=AAA, Replacement:=BBB, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End Sub
-----------------------------------------------------------------------
ドラックしたセル内の文字列から、マクロ表紙のセル(2,1)(2,2)で指定された
文字に変換する。
Sub 文字書換()
' 任意文字削除
AAA = Workbooks(AAname).Worksheets(BBname).Cells(2, 1).Value
BBB = Workbooks(AAname).Worksheets(BBname).Cells(2, 2).Value
AAA・BBBの両方にデータが無いときは、強制終了させる。
If AAA = "" Or BBB = "" Then Exit Sub
変数AAAで指定された文字を変数BBBで指定された文字に置換する。
Selection.Replace What:=AAA, Replacement:=BBB, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End Sub
-----------------------------------------------------------------------
マクロ表紙のセル 10行目のデータを入力規則のリストデータとして設定する。
Sub リストデータ設定()
'
range_data AAA, BBB <---- ドラックしたセル範囲を取得
ドラッグ範囲を取得する。
With ActiveWindow.RangeSelection
N1 = .Rows.Row <---- 縦位置 開始セル位置を取得
N2 = .Rows(.Rows.Count).Row <---- 縦位置 終了セル位置を取得
y1 = .Columns.Column <---- 横セル位置を取得
End With
マクロ表紙のセル 10行目のデータの数を取得する。
CNT = Workbooks(AAname).Sheets(BBname).Cells(2, 10).Value
(半角スペース),○○,○○,○○,○○・・・・の文字列を作る。
AAA = " "
For ii = 1 To CNT
AAA = AAA & "," & _
Workbooks(AAname).Sheets(BBname).Cells(ii + 2, 10).Value
Next ii
ドラッグ範囲(縦方向のみ)に、文字列 AAA をセルに書き込む。
For ii = N1 To N2
ActiveSheet.Cells(ii, y1).Select <---- 書込みセルを指定
文字列 AAA をリストデータとしてセルに書き込むサブルーチン。
セルリスト設定 AAA
Next ii
完了メッセージ
MsgBox ("Range( " & AAA & ":" & BBB & " ) リストデータ設定完了")
'
End Sub
-----------------------------------------------------------------------
文字列 AAA をリストデータとしてセルに書き込むサブルーチン。
Sub セルリスト設定(リストD As Variant)
With Selection.Validation
.Delete <---- 入力規則を削除
ここから、入力規則を設定する。
Type:=xlValidateList は、入力値のタイプ「リスト」に設定
AlertStyle:=xlValidAlertStop は、エラーメッセージのスタイルを
「停止」に設定
Operator:=xlBetween は、無意味なものですが記述します。
Formula1:=リストD は、リストデータを指定する。
ここでは、変数(リストD)に設定していますが、直接指定することも
できます。
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=リストD
.IgnoreBlank = False <-- セル範囲への空白値の入力を禁止する
.InCellDropdown = True <-- ドロップダウン リストを表示します
.IMEMode = xlIMEModeHiragana <-- IMEコントロールは、
End With 「ひらがな」指定
End Sub
-----------------------------------------------------------------------
セルをドラッグした範囲のリストの設定を解除するサブルーチン。
Sub リストデータ設定解除()
range_data AAA, BBB <---- ドラックしたセル範囲を取得
data1 = AAA & ":" & BBB
Selection.Validation.Delete <---- 入力規則を削除
完了メッセージ
MsgBox ("Range( " & AAA & ":" & BBB & " ) リストデータ解除完了")
End Sub
-----------------------------------------------------------------------
セルをドラッグした範囲をレンジデータ( ○○n:○○n )として
作成するサブルーチン。
Sub range_data(AAA, BBB As Variant)
'
With ActiveWindow.RangeSelection
y1 = .Columns.Column
y2 = .Columns(.Columns.Count).Column
x1 = .Rows.Row
x2 = .Rows(.Rows.Count).Row
End With
セルをドラッグした範囲をレンジデータ( ○○n:○○n )を計算式で作成します
AAA = "": BBB = ""
y1を元にセル位置(横方向 A ～ ZZ )を y1 ÷ 26 で求める。
( 26 の意味は、アルファベット A ～ Z が、26文字だからです。)
y1=1の時は、A (コード= 64 + 1)・y1=2 -->B (コード= 64 + 2) になる
ように計算する。
ただし、y1が、1 ～ 26 の時は、セル位置が、An ～ Zn になるよう計算する。
また、y1 ÷ 26 が、割り切れる時に別処理をします。つまり、Z の時には、
26で割切れてしまうので、余りが無いとき(M2 = 0)には、M2 = 26 にして、
Z になるようにしています。
M2 の計算は、26 で割った時の余りだけを求める式です。
' セルの始まり A ～ XFD まで対応させる
下記の詳細の解説は、「Excelマクロの2007・2010への移行」の「7項 イン
プットボックスでセル参照結果を取得する方法」でしていますので参照して
ください。
'
AAA = "": BBB = ""
' AAA の処理
' A ～ ZZ(702) と AAA ～ XFD(16384) の範囲の判定
If (y1 - 703) < 0 Then
' A ～ ZZ の処理
M1 = Int(y1 / 26): M2 = y1 Mod 26
If M2 = 0 Then M1 = M1 - 1: M2 = 26
'
If M1 = 0 Then
AAA = Chr(64 + M2) & x1
Else
AAA = Chr(64 + M1) & Chr(64 + M2) & x1
End If
'
Else
' AAA ～ XFD の処理
M = y1 - 26 <---- A ～ Z の分を引く
'
M1 = Int(M / 676): M2 = M Mod 676
' 二桁目 A の時、M3=0 になるので 26 を加算する
M3 = Int((M2 + 26) / 26): If M2 = 0 Then M1 = M1 - 1: M3 = 26
'
AAA = Chr(64 + M1): M4 = M2 Mod 26
If M4 = 0 Then M4 = 26
AAA = AAA & Chr(64 + M3) & Chr(64 + M4) & x1
'
End If
' BBB の処理
If (y2 - 703) < 0 Then
' A ～ ZZ の処理
M3 = Int(y2 / 26): M4 = y2 Mod 26
If M4 = 0 Then M3 = M3 - 1: M4 = 26
'
If M3 = 0 Then
BBB = Chr(64 + M4) & x2
Else
BBB = Chr(64 + M3) & Chr(64 + M4) & x2
End If
'
Else
' AAA ～ XFD の処理
M = y2 - 26 <---- A ～ Z の分を引く
'
M1 = Int(M / 676): M2 = M Mod 676
M3 = Int((M2 + 26) / 26): If M2 = 0 Then M1 = M1 - 1: M3 = 26
'
BBB = Chr(64 + M1): M4 = M2 Mod 26
If M4 = 0 Then M4 = 26
BBB = BBB & Chr(64 + M3) & Chr(64 + M4) & x2
'
End If
End Sub
-----------------------------------------------------------------------
数字の文字列を数値に変換するサブルーチン。
Sub 変換開始数字()
' 数値と文字列を扱うため、Variant で変数を宣言します。
Dim AA As Variant
Dim S, E As Integer <-- 整数の数値として扱う変数を宣言します
With ActiveWindow.RangeSelection <-- ドラッグされたセル範囲を取得
S = .Rows.Row <-- 開始セル行
E = .Rows(.Rows.Count).Row <-- 終わりセル行
x = .Columns.Column <-- セルの縦位置
End With
For i = S To E <---- セル位置 S から E まで繰返し実行する。
AA = ActiveSheet.Cells(i, x).Value
' 文字列か数字列か判定する
If VarType(AA) = vbString Then <-- データが文字列か確認する。
AA = Val(AA) <-- 数値文字列を数値にする。
If AA <> 0 Then <-- 数値が 0 の時は書込みしない。
ActiveSheet.Cells(i, x).Select <-- セル位置(i, x)を選択する。
Selection.NumberFormatLocal = "0_ " <-- セルの書式を数値にする。
' 数値にしたデータを書き込む
ActiveSheet.Cells(i, x).Value = AA
End If
End If
Next i
End Sub
-----------------------------------------------------------------------
数値を数字の文字列に変換するサブルーチン。
Sub 変換開始文字()
' 数値と文字列を扱うため、Variant で変数を宣言します。
Dim AA As Variant
Dim S, E As Integer <---- 整数の数値として扱う変数を宣言します
With ActiveWindow.RangeSelection <-- ドラッグされたセル範囲を取得
S = .Rows.Row <-- 開始セル行
E = .Rows(.Rows.Count).Row <-- 終わりセル行
x = .Columns.Column <-- セルの縦位置
End With
For i = S To E <---- セル位置 S から E まで繰返し実行する。
AA = ActiveSheet.Cells(i, x).Value
' 文字列か数字列か判定する
If VarType(AA) <> vbString Then <-- データが数値か確認する。
AA = CStr(AA) <-- 数値を文字列にする。
If AA <> 0 Then <-- 数値が 0 の時は書込みしない。
ActiveSheet.Cells(i, x).Select <-- セル位置(i, x)を選択する。
Selection.NumberFormatLocal = "@" <-- セルの書式を文字列にする
' 数字の文字列にしたデータを書き込む。
ActiveSheet.Cells(i, x).Value = AA
End If
End If
Next i
End Sub
-----------------------------------------------------------------------
シート全体の保護解除するサブルーチン。
Sub 計算式セル色解除()
Dim Abc As Integer
'
Abc = MsgBox("[計算式セル色解除]を実行するとセルの色付けと計算式の
ロックが解除されますが良いですか。", vbYesNo, "ロック解除確認")
If Abc = vbNo Then Exit Sub ' Noの時終了 <-- 確認メッセージ
ActiveSheet.Unprotect <-- シートの保護解除をする
計算式のあるセルだけ選択する。
Selection.SpecialCells(xlCellTypeFormulas).Select
Selection.Interior.ColorIndex = xlNone <-- 選択されたセルの色を消す
シートの表示が、中途半端にならないようにする。
' レンジA1を選択し、シートの左上部分が表示するようにする。
Range("A1").Select
End Sub
-----------------------------------------------------------------------
計算式のあるセルに色を付けるサブルーチン。
Sub 計算式セル色付()
Dim Abc As Integer
'
Abc = MsgBox("[計算式セル色解除]を実行するとセルの色付けと計算式の
ロックが解除されますが良いですか。", vbYesNo, "ロック解除確認")
If Abc = vbNo Then Exit Sub ' Noの時終了 <-- 確認メッセージ
ActiveSheet.Unprotect <-- シートの保護解除をする
数式が含まれているセルを選択する。
Selection.SpecialCells(xlCellTypeFormulas).Select
With Selection.Interior
.ColorIndex = 15 <-- 色コード 25%灰色
.Pattern = xlSolid 参考 色コード 3 : 赤, 6 : 黄色, 8 : 水色
End With
Range("A1").Select
End Sub
-----------------------------------------------------------------------
シート全体の保護解除するサブルーチン。
Sub 保護解除()
Dim Abc As Integer
'
Abc = MsgBox("計算式のロックを解除します。", vbYesNo, _
"ロック解除確認")
If Abc = vbNo Then Exit Sub ' Noの時終了 <-- 確認メッセージ
'
ActiveSheet.Unprotect <---- シートの保護解除をする。
Cells.Select <---- すべてのセルを選択する。
Selection.Locked = False <---- 選択されたセルを保護解除する。
Range("A1").Select
End Sub
-----------------------------------------------------------------------
選んだセルを書替え出来ないようにロックするサブルーチン。
Sub 計算式ロック()
'
Unload UForm101 <---- ニーザーフォーム UForm101 を消す
Application.ScreenUpdating = False <---- 画面更新を停止する
Workbooks(AAname).Activate
Worksheets(BBname).Activate <---- マクロの表紙をアクティブにする
AAA = ""
セル位置 L を 2,000 行から上に検索させ、最初にデータが設定されている
セル位置を求める式。
NN = ActiveSheet.Range("L2000").End(xlUp).Row
ばらばらに、指定されたセル範囲をまとめて一つの文字列にする。
For N = 1 To NN - 1
強制的に、改行させたいときに _ を書くと、次の行も続きと判断される
AAA = AAA & _
Workbooks(AAname).Sheets(BBname).Cells(N + 1, 12).Value & _
":" & Workbooks(AAname).Sheets(BBname).Cells(N + 1, 13).Value
If N < NN - 1 Then AAA = AAA & ","
Next N
N4 = Workbooks(AAname).Sheets(BBname).Cells(6, 1).Value
Bname = Workbooks(AAname).Worksheets(BBname).Cells(3, 1).Value
Sname = Workbooks(AAname).Worksheets(BBname).Cells(4, 1).Value
Workbooks(Bname).Activate
' マクロが呼ばれたときのシートを表示する。
Worksheets(Sname).Activate
Application.ScreenUpdating = True <---- 画面更新を停止解除
ActiveSheet.Unprotect <---- セルのロックを解除する
Cells.Select
'----------------------------------------------------
If N4 = 1 Then <---- 選んだセル範囲を保護する。
' すべてのセルのセルロックフラグをOFFする。
Selection.Locked = False
' 指定されたセル範囲をまとめて選択する
Range(AAA).Select
' 選択されたセル範囲のセルロックフラグをONする。
Selection.Locked = True
シートの保護を実行する。Contentsは、Trueでセルの保護、
UserInterfaceOnly：省略可。Trueを指定すると、画面上からの変更は
保護されますが、マクロからの変更は可能になる設定。
ActiveSheet.Protect Contents:=True, userinterfaceonly:=True
Exit Sub
End If
'----------------------------------------------------
If N4 <> 1 Then <---- 選んだセル範囲外を保護する。
' すべてのセルのセルロックフラグをONする。
Selection.Locked = True
' 指定されたセル範囲をまとめて選択する
Range(AAA).Select
' 選択されたセル範囲のセルロックフラグをOFFする。
Selection.Locked = False
シートの保護を実行する。
ActiveSheet.Protect Contents:=True, userinterfaceonly:=True
End If
End Sub
-----------------------------------------------------------------------
選んだセルを書替え出来ないようにロックするサブルーチン。
Sub 範囲をドラッグして指定()
Dim Hogo_Range As Range
Bname = ActiveWorkbook.Name <---- ブック名取得
Sname = ActiveSheet.Name <---- シート名取得
' ブック名保存
Workbooks(AAname).Worksheets(BBname).Cells(3, 1).Value = Bname
' シート名保存
Workbooks(AAname).Worksheets(BBname).Cells(4, 1).Value = Sname
Application.ScreenUpdating = False <---- 画面更新を停止する
Workbooks(AAname).Activate
Worksheets(BBname).Activate <---- マクロの表紙をアクティブにする
Range("L2:M1000").Select <---- セル範囲 "L2:M1000" を選択する
セルの内容を消去する。
Selection.ClearContents ' 消去
「マクロの表紙」のセル範囲を書き込む位置のタイトル文字の書込み。
ActiveSheet.Cells(1, 12).Value = "セル始まり" '
ActiveSheet.Cells(1, 13).Value = "セル終わり" '
Range("L1").Select
ドラック範囲のデータの書込み位置を 2 する
Workbooks(AAname).Sheets(BBname).Cells(5, 1).Value = 2
Workbooks(Bname).Activate
Worksheets(Sname).Activate <---- 元のブック・シートに戻す
Application.ScreenUpdating = True <---- 画面更新を停止解除
If UForm100.OptionButton1 = True Then
ドラック範囲内の保護フラグセット
Workbooks(AAname).Sheets(BBname).Cells(6, 1).Value = 1
On Error Resume Next
本来１行で書くのですが、表示でオーバーするので、改行を入れています
Type:=8 は、レンジ(セル範囲の選択)の設定です。
Set Hogo_Range = Application.InputBox
(prompt:="保護する範囲をドラッグしてください", Type:=8)
On Error GoTo 0
キャンセルがクリックされたら終了させます
If Hogo_Range Is Nothing Then Exit Sub ' キャンセル時の処理
Else
ドラック範囲外の保護フラグセット
Workbooks(AAname).Sheets(BBname).Cells(6, 1).Value = 0
On Error Resume Next
本来１行で書くのですが、表示でオーバーするので、改行を入れています
Set Hogo_Range = Application.InputBox
(prompt:="保護しない範囲をドラッグしてください", Type:=8)
On Error GoTo 0
If Hogo_Range Is Nothing Then Exit Sub ' キャンセル時の処理
End If
' H25.06.22 変更・追加
' Address(False, False)でレンジデータが取得できます。
CCC = Hogo_Range.Address(False, False)
' レンジデータの区切り文字( : )の位置を取得します。
M = InStr(1, CCC, ":")
' ドラッグ範囲の始まり位置を取得します。
AAA = Mid(CCC, 1, M - 1)
' レンジデータの文字数を取得します。
NN = Len(CCC)
' ドラッグ範囲の終わり位置を取得します。
BBB = Mid(CCC, M + 1, NN - M)
'変数AAAとBBBにドラッグ範囲の始まりと終わり位置がレンジデータと
' して取得できます。
N = Workbooks(AAname).Sheets(BBname).Cells(5, 1).Value
ドラック範囲のデータを「マクロの表紙」のセル位置(N,12)と(N,13)に書込む
Workbooks(AAname).Sheets(BBname).Cells(N, 12).Value = AAA
Workbooks(AAname).Sheets(BBname).Cells(N, 13).Value = AAA
Unload UForm100 <-- ニーザーフォーム UForm100 を消す
UForm101.Show vbModeless <-- ユーザーフォーム UForm101 を表示
End Sub
-----------------------------------------------------------------------
保護のかかったセルをリストアップしてセルに色を付けるサブルーチン。
Sub Locked_Cell_get()
' CheckBox1 にチェックが入ったら、使用範囲自動選択
If UForm100.CheckBox1 = True Then ActiveSheet.UsedRange.Select
' ドラック範囲を取得
range_data AAA, BBB
C_Range = AAA & ":" & BBB <---- ドラック範囲のアドレス
'-----------------------------------------------------------
' 「表紙」のリストデータ消去 データの個数を取得
N = Workbooks(AAname).Sheets(BBname).Cells(2, 15).Value
if N >2 then <---- N = 2 の時は、データなし
For i = 3 To N
Workbooks(AAname).Sheets(BBname).Cells(i, 15).Value = ""
Next i
End If
'-----------------------------------------------------------
' 保護のかかったセルをリストアップする。
II = 3
' ドラックされたセル範囲をすべて検査する。
For Each CL_Range In ActiveSheet.Range(C_Range)
' 保護なし: False, 保護有: True
If CL_Range.Locked = True Then
' 保護のかかっているセル位置データをリストアップする。
Workbooks(AAname).Sheets(BBname).Cells(II, 15).Value = _
CL_Range.Address
II = II + 1
End If
Next
--------------------------------------------------------------------
※ 参考情報 ※
マクロの処理で取得したデータを別々のタイミングで使用するような時には、そのデータをわ
ざわざ「マクロの表紙」に書込む方法をとって処理しています。
なお、変数の値は、ブックを 閉じるまで有効であると書かれていますが、私は、確実な方法として、わざとシート上に結果
を書込む方法にしています。何といっても確実に残るし、データの確認もできるし、わかりや
すくなるので、この方法がベストではないかと個人的に思っています。
--------------------------------------------------------------------
' リストアップしたセルに色を付ける。
N = Workbooks(AAname).Sheets(BBname).Cells(2, 15).Value
if N >2 then <---- N = 2 の時は、データなし
For II = 3 To N
' リストから、セル位置データを読み出す。
CL_Range = _
Workbooks(AAname).Sheets(BBname).Cells(II, 15).Value
Range(CL_Range).Select <---- セルを選択
' セルに色を付ける
With Selection.Interior
.Pattern = xlSolid <---- 塗りつぶし
' 参考 色コード 1: 黒, 2: 白, 3: 赤, 4: 緑
' 5: 青, 6: 黄, 7: マゼンタ, 8: 水色
.ColorIndex = 6 <---- 色指定 黄色
End With
Next II
End If
End Sub
-----------------------------------------------------------------------
リストアップしたセルの色を消すサブルーチン。
Sub Cell_Color_off()
' リストアップしたセルの色を消す。 データの個数を取得
N = Workbooks(AAname).Sheets(BBname).Cells(2, 15).Value
if N >2 then <---- N = 2 の時は、データなし
For II = 3 To N
' リストから、セル位置データを読み出す。
CL_Range = _
Workbooks(AAname).Sheets(BBname).Cells(II, 15).Value
Range(CL_Range).Select <---- セルを選択
Selection.Interior.Pattern = xlNone <---- 塗りつぶしなし
Next II
End If
End Sub
-------------------- ここから module2 コード ----------------------
'-----------------------------------------------------------
' H26.02.25 セル幅・高さをmm単位で設定する機能追加
'-----------------------------------------------------------
Sub 行の高さ()
'
HT = Workbooks(AAname).Worksheets(BBname).Cells(8, 3).Value
HF = Workbooks(AAname).Worksheets(BBname).Cells(9, 3).Value
'
CC = Val(UForm102.TextBox1.Text)
If CC = 0 Then CC = 5
' mm を ポイントに数値変換する。
' HT : 変換定数 HF : 変換補正値
NN = Int(CC / HT + HF)
Selection.RowHeight = NN <----セルの高さを設定する。
'
End Sub
Sub セル幅変更()
Dim Cell_Range As Range
Dim XXX As Variant
Dim SS, SS1 As Single
Dim Moji1, Moji2 As String
Dim Font_Name, Font_Size As Variant
'
On Error Resume Next
Set Cell_Range = Application.InputBox _
(prompt:="幅・高さを変更するセルを選択してください", Type:=8)
On Error GoTo 0
If Cell_Range Is Nothing Then Exit Sub <----キャンセル時の処理
'-------------------------------------------------------
' 指定されたセル範囲を取得する。
'-------------------------------------------------------
Moji1 = Cell_Range.Address(False, False)
Moji = Moji1
' セルの範囲が一つか判定する。
mm = InStr(1, Moji1, ":", 1)
If mm = 0 Then
' セル範囲 シングル
文字抽出 Moji
' "B:B" のようにする
C_Range = Moji & ":" & Moji
AAA = Moji1 <---- セル位置
Else
' セル範囲 複数
文字抽出 Moji
' "B:F" のようにする
C_Range = Moji
'
XXX = Split(Moji1, ":")
AAA = XXX(0) <---- 先頭セル位置
BBB = XXX(1) <---- 最終セル位置
End If
'--------------------------------------------------------
' 先頭セルのフォントとサイズを退避
'--------------------------------------------------------
Font_Name = Range(AAA).Font.Name ' Font Name get
Font_Size = Range(AAA).Font.Size ' Font Size get
' マクロの表紙へ一時退避する。
Workbooks(AAname).Worksheets(BBname).Cells(2, 6).Value = Font_Name
Workbooks(AAname).Worksheets(BBname).Cells(3, 6).Value = Font_Size
'--------------------------------------------------------
mm = Val(UForm102.TextBox2.Text)
' 設定ない時には、2mmの設定とする。
If mm = 0 Then mm = 2
'--------------------------------------------------------
' フォントの種類とサイズを規定値にする。
Range(Moji1).Font.Name = "ＭＳ Ｐゴシック"
Range(Moji1).Font.Size = 11
'-------------------------------------------------------
' ColumnWidth は、半角の 0 の文字幅を基準として文字数で幅が
' 設定するようになっているので mm 設定を文字数に直してかつ、
' 補正をして幅を変更する。
'-------------------------------------------------------
' 補正値
FF = Workbooks(AAname).Worksheets(BBname).Cells(10, 3).Value
SS = Int((mm + 1) / 2) - FF <---- (2mm/文字に変換する)-(補正値)
'
Columns(C_Range).ColumnWidth = SS <---- セル幅変更
'--------------------------------------------------------
' マクロの表紙から読込み、フォントとサイズを元に戻す。
Range(Moji1).Font.Name = _
Workbooks(AAname).Worksheets(BBname).Cells(2, 6).Value
Range(Moji1).Font.Size = _
Workbooks(AAname).Worksheets(BBname).Cells(3, 6).Value
'--------------------------------------------------------
End Sub
Sub 文字抽出(Moji As Variant)
'
' 数字以外の文字を抽出する
'
Dim Moji_A, Moji_B As String
Dim Loop_cnt As Integer
'
Moji_A = ""
' セル位置文字列データから数字(セルの縦位置)だけを消去する。
For Loop_cnt = 1 To Len(Moji)
Moji_B = Mid(Moji, Loop_cnt, 1)
' True にすると数値だけが抽出される
' 数字どうか判定する。
If IsNumeric(Moji_B) = False Then Moji_A = Moji_A & Moji_B
Next Loop_cnt
' 数字だけを消去したセル位置文字列データ
' (横方向のセル位置)
Moji = Moji_A
'
End Sub |
|
