| 2019.02.08 現在
------------------ ここから ThisWorkBook コード ----------------------
ブックを閉じた時に、アドインとユーザーフォームを消去する
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.CommandBars("Cell").Reset
B02リセット
Unload Form2
End Sub
------------------------------------------------------------------------
ブックを開いた時に、アドインの設定とForm2のユーザーフォームを開く
Private Sub Workbook_Open()
Application.CommandBars("Cell").Controls(1).BeginGroup = True
B01セット
Form2.Show vbModeless
End Sub
-------------------------- ここから Form2のコード -------------------
[写真読込貼付け]ボタンクリックで写真貼付を実行
Private Sub CommandButton1_Click()
90°回転のチェックボタンをチェックする。
mm = 1: If Form2.CheckBox2 = True Then mm = -1
S写真選択 mm
貼付位置選択のチェックボタンを切り替える
With Form2
If .OB1 = True Then .OB1 = False: .OB2 = True: GoTo SCB1end
If .OB2 = True Then .OB2 = False: .OB3 = True: GoTo SCB1end
If .OB3 = True Then .OB2 = False: .OB3 = False: .OB1 = True
SCB1end:
End With
End Sub
------------------------------------------------------------------------
[BOOK作成]ボタンクリックでシート原稿をコピーし、
新規ブックとして作成する
Private Sub CommandButton52_Click()
'シート別BOOKへcopy
AAA = Form2.TextBox1.Text <---- TextBox1のテキストデータを
ブック名にする
If AAA = "" Then Exit Sub
'
ADir = Workbooks(AAname).Worksheets(CCname).Cells(3, 1).Value
' パスなしの時には、書込みフォルダ設定へ
If ADir = "" Then パス設定W: Exit Sub <---- 読込みのパスの設定が
が無い時は強制終了
' 保存されているパスが有効かチェックする。
'--------------------------------------------------------------------
' このマクロは、Windows Script Host Object Model を使用して
' いるので、マクロ-ツール-参照設定で上記のオブジェクトに
' チェックを入れて、使用すること。
'--------------------------------------------------------------------
With New IWshRuntimeLibrary.FileSystemObject
If Not .FolderExists(ADir) Then
MsgBox "書込み先のフォルダ" & BBB & "がありません。", vbExclamation
パス設定W ' パス無効の時には、書込みフォルダ設定へ
Exit Sub
End If
End With
'
Sheets("原稿").Select
Sheets("原稿").Copy <---- シート「原稿」をコピーする
Sheets("原稿").Select
Sheets("原稿").Name = AAA <---- TextBox1のテキストデータを
'BOOK保存 ブック名にする
On Error GoTo CommandButton52_err: <---- エラーの時のジャンプ先
' 書き込み先のパス
ADir = Workbooks(AAname).Worksheets(CCname).Cells(3, 1).Value
'
互換モード対応 Excelのバージョンコードを取得し、保存形式を決める
'
N = Val(Application.Version)
' Excelのバージョン"2000","2002","2003"
If N = 9 Or N = 10 Or N = 11 Then GoTo Button52A:
' Excelのバージョン"2007","2010","2013"
If N = 12 Or N = 14 Or N = 15 Or N = 16 Then GoTo Button52B:
MsgBox ("このExcelのバージョンは、対応していませんので、_
終了します。"): Exit Sub
'
Button52A:
互換モードの時の、処理(Excelのバージョン"2000","2002","2003")
AAA = ADir & "\" & AAA & ".xls"
ActiveWorkbook.SaveAs AAA
GoTo Button52C:
'
Button52B:
Excelのバージョン"2007","2010"の時の、処理
AAA = ADir & "\" & AAA & ".xlsx" <---- 書込み先のフルパスを作成
'---------------------------------------------------------------------
' Excel 2007 対策 書込み時に、拡張子の指定がいる。
' 51=*.xlsxモードで保存
'H23.12.13
Application.DisplayAlerts = False <---- 警告メッセージを止める
( TextBox1のテキストデータ ).xlsx で書込み
ActiveWorkbook.SaveAs Filename:=AAA, _
accessMode:=xlShared12, FileFormat:=51
Application.DisplayAlerts = True <---- 警告メッセージを抑制を解除
'ActiveWorkbook.SaveAs AAA
'Workbooks(AAname).Sheets(BBname).Cells(7, 1).Value = _
ActiveWorkbook.Name
'---------------------------------------------------------------------
' Excel 2007 対策
' ブックの共有解除をしないとシートコピーできない。
Application.DisplayAlerts = False
シートコピーのため、事前にブックの共有解除
If ActiveWorkbook.MultiUsered12iting Then _
ActiveWorkbook.ExclusiveAccess
Application.DisplayAlerts = True
'---------------------------------------------------------------------
Button52C:
Workbooks(AAname).Sheets(CCname).Cells(2, 1).Value = _
Form2.TextBox1.Text
Exit Sub
保存先が、設定されていないと、実行時エラー(エラーNo.1004)に
なるので、その処理をする。
CommandButton52_err:
M = Err.Number <---- エラー番号確認用(デバック用)
If M = 75 Then MsgBox ("設定されているフォルダのパス名は、無効です。")
If M = 76 Then MsgBox ("設定されているフォルダのパス名は、間違っています。")
if M = 1004 Then MsgBox ("同じブック名があるので保存しません。")
End Sub
---------------------------------------------------------------------
[シートコピー]ボタンクリックでシートコピーを実行
Private Sub CommandButton53_Click()
シートコピー
End Sub
---------------------------------------------------------------------
[↓]ボタンクリックで下向き矢印を描画する
Private Sub CommandButton54_Click()
' 下向き矢印
'赤線描画する
With Selection <---- 書込み位置情報取得
x = .Left
y = .Top
x2 = .Width
y2 = .Height
End With
xx = 142 / 4 + 30 <---- xx=65.5 便宜上この様にしています
図形を描くときには、この様に計算式にしておくと変更時、
分かり安くなります。
' 横線
ActiveSheet.Shapes.AddLine(x + xx - 20, y - 21, x + xx, y).Select
------------------------------------------------------------------------
図形の表示位置・サイズの指定方法
上記、( )内の意味は、
( 始点の横位置, 始点の縦位置, 終点の横位置, 終点の縦位置 )
位置座標の原点は、シート上の左上の端が、横 0, 縦 0 になります。
------------------------------------------------------------------------
Selection.ShapeRange.Line.EndArrowheadStyle = _
msoArrowheadTriangle <---- 矢印 三角を指定
Selection.ShapeRange.Line.EndArrowheadLength = _
msoArrowheadLengthMedium <---- 長さ 中を指定
Selection.ShapeRange.Line.EndArrowheadWidth = _
msoArrowheadWidthMedium <---- 幅 中を指定
Selection.ShapeRange.Line.Weight = 2.25 <---- 線の太さ
Selection.ShapeRange.Line.ForeColor.RGB = vbred12 <---- 線の色 赤を指定
Selection.ShapeRange.ZOrder msoBringToFront <-- 矢印の表示を
前面にする指定。
End Sub
------------------------------------------------------------------------
[↑]ボタンクリックで下向き矢印を描画する
Private Sub CommandButton55_Click()
' 上向き矢印
'赤線描画する
With Selection
x = .Left
y = .Top
x2 = .Width
y2 = .Height
End With
'
xx = 142 / 4 + 30
ActiveSheet.Shapes.AddLine(x + xx - 20, y , x + xx - 4, y - 21).Select
Selection.ShapeRange.Line.EndArrowheadStyle = _
msoArrowheadTriangle
Selection.ShapeRange.Line.EndArrowheadLength = _
msoArrowheadLengthMedium
Selection.ShapeRange.Line.EndArrowheadWidth = _
msoArrowheadWidthMedium
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.ForeColor.RGB = vbred12
Selection.ShapeRange.ZOrder msoBringToFront
End Sub
------------------------------------------------------------------------
[書込み場所設定]ボタンクリックで書込み先のディレクトリーを設定する。
Private Sub CommandButton56_Click()
パス設定W
End Sub
------------------------------------------------------------------------
[写真読込場所設定]ボタンクリックで写真読込先のディレクトリーを設定する。
Private Sub CommandButton57_Click()
パス設定R
End Sub
------------------------------------------------------------------------
[写真変更禁止]ボタンクリックで張付け写真変更禁止を設定する。
Private Sub CommandButton2_Click()
' 写真変更禁止の設定
' セル範囲("B2:G42")を保護する。
Lock_Hani = "B2:G42" <---- 保護する範囲を設定する
写真変更禁止 Lock_Hani
End Sub
------------------------------------------------------------------------
[シート名変更]ボタンクリックで、アクティブシート名を
[TextBox2]の名前に変更します。
Private Sub CommandButton16_Click()
' H29.01.19 追加
Gname = ActiveWorkbook.Name
If Gname = AAname Then Exit Sub
' シート名変更
AAA = ActiveSheet.Name
Sheets(AAA).Select
Sheets(AAA).Name = Form2.TextBox2.Value
Range("A1").Select
End Sub
------------------------------------------------------------------------
ユーザーフォームの左上隅の□をクリックすると、選択したセル・図形の
サイズが表示されます。
Private Sub CommandButton7_Click()
図形位置サイズ
End Sub
------------------------------------------------------------------------
[文字書込]ボタンクリックで、選択されたセルにリストの指定された
文字列を書き込みます。
Private Sub CB2_Click()
Dim 文字 As String
文字 = ListBox1.Value
S繰返 文字
End Sub
------------------------------------------------------------------------
ユーザーフォームのイニシャライズの処理
Private Sub UserForm_Initialize()
Dim I As Integer
ListBox1に、「マクロの表紙」の16行目のデータをリストデータと
して書込みます。
With ListBox1
I = 3
Do While Workbooks(AAname).Sheets(CCname).Cells(I, 16) <> ""
ListBox1.AddItem Workbooks(AAname).Sheets(CCname).Cells(I, 16)
I = I + 1
Loop
End With
Form2.OB1 = True <---- オプションボタン1をON(True)にします。
TextBox1に、「マクロの表紙」のセル位置(2, 1)のデータを書込みます。
If Workbooks(AAname).Sheets(CCname).Cells(2, 1).Value <> "" Then
Form2.TextBox1.Text = _
Workbooks(AAname).Sheets(CCname).Cells(2, 1).Value
End If
End Sub
--------------------- ここから module1のコード -------------------
マクロブック・シートの名前を定義、変数の宣言
Public AAA, mm, datax(16), ADir As String
Public N, Nmax, Zom, Tate, Yoko, Ichi1, Ichi2 As Single
Public Ue, Ue1, Ue2, Ue3, TT, SS As Single
Public Ue4, Ue5, Ue6 As Single
Public x1, x2, y1, y2, x3, x4, x, y As Single
Public Const AAname As String = "写真貼付マクロ.xlsm"
Public Const CCname As String = "表紙"
Public BBB, CCC, Kname, B5name, S6name, B7name, S8name As String
Public mystatusbar, Photname, Fpasu As String
Public myFname, Sname, Gname, Tname As String
' ネットワークドライブの参照をしたい時には、下記を追加して、
'----------------------------------------------------------------------
' ネットワークドライブの参照
' VBA7という定数を使うとEXCELのバージョンが2007以前か2010以降か
' が区別できる。
' Win64は、実行しているEXCELのバージョンが64bitか32bitかの区別が出来る。
#If VBA7 And Win64 Then
'64Bit 版 かつ 2010以降
Private Declare PtrSafe Function SetCurrentDirectory _
Lib "kernel32" Alias "SetCurrentDirectoryA" _
(ByVal lpPathName As String) As Long
#Else
'32Bit 版
Private Declare Function SetCurrentDirectory _
Lib "kernel32" Alias "SetCurrentDirectoryA" _
(ByVal lpPathName As String) As Long
#End If
'-------------------------------------------------------------------
-------------------------------------------------------------------
Excelブックがオープンした時に実行するサブルーチン
Sub auto_open()
'----------------------------------------------------
' Excel 起動時にメニューバーをアドインに移動させる処理
'----------------------------------------------------
この様にしないといつまでも Excelブックがオープンしない
' タイムディレー処理
Application.OnTime Now + TimeValue("00:00:00"), "AddIN"
' 直ぐに、サブルーチン AddIN を実行させる
End Sub
--------------------------------------------------------------------
メニューバーを「アドイン」に移動させる処理
Sub AddIN()
Sheets(CCname).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"時は、アドインに移動
Application.SendKeys ("%X%") <---- [ALT]-->[X]-->[ALT]の
キー入力を実行
End Sub
--------------------------------------------------------------------
アドインの表示処理
Sub B01セット()
'
' Excel 2007/2010 に対応するように変更する
' 新規ブックは、*.xlsx(Excel2007形式)で作成する。
'
Dim Mycontrol As CommandBarControl
Dim Mysubmenu As CommandBarControl
'
Application.CommandBars("Worksheet Menu Bar").Reset
Set Mycontrol = CommandBars("Worksheet Menu Bar"). _
Controls.Add(msoControlPopup)
Mycontrol.Caption = "【■】"
Mycontrol.OnAction = "再表示"
' 表紙 関数書込み
Worksheets(CCname).Activate ' 「 表紙 」をアクティブ化
ActiveSheet.Cells(2, 16).Select
ActiveCell.FormulaR1C1 = "=COUNTA(R[1]C:R[31]C)"
End Sub
--------------------------------------------------------------------
アドインの削除処理
Sub B02リセット()
Application.CommandBars("Worksheet Menu Bar").Reset
'CommandBars("Worksheet Menu Bar").Controls("【■】").Delete
End Sub
--------------------------------------------------------------------
ニーザーフォームの表示処理
Sub 再表示()
Form2.Show vbModeless
End Sub
--------------------------------------------------------------------
(おまけ)マクロの実行のさせ方
次の手順で、実行をさせます。
[ツール] --> [マクロ] --> [マクロの表示] --> 実行のさせたい
マクロを選び[実行]
--------------------------------------------------------------------
(おまけ)Excelのバージョンコードを取得表示する。
Sub Aexcel_ver()
Dim sv As String
' Excelのバージョンコードを取得
N = Val(Application.Version)
If N = 9 Then sv = "2000"
If N = 10 Then sv = "2002"
If N = 11 Then sv = "2003"
If N = 12 Then sv = "2007"
If N = 14 Then sv = "2010"
If N = 15 Then sv = "2013"
If N = 16 Then sv = "2016"
MsgBox ("Excelのバージョンコードは " & N & " : Excel" & sv & " です")
End Sub
--------------------------------------------------------------------
Form2の表示位置を表示する。
Sub ichi()
With Form2
MsgBox "Left=" & .Left & " " & "Top=" & .Top
End With
End Sub
------------------------------------------------------------------------
ダイヤログを表示し、参照したいフォルダのパス情報を取得するサブルーチン。
プログラムは、下記のとおりにして下さい。
また、参照設定で Microsoft Scripting Runtime と
Microsoft Shell Controls And Automation の２つの設定を忘れない
ようして下さい。
設定の仕方が、分からない方は、このマクロをダウロードし、不要な箇所を
削除して、流用してください。
[参照設定]のダイヤログの開き方
次の手順で、VBE(Visual Basic Editor)を開きます。
①[ツール] --> [マクロ] --> [マクロの表示] --> 適当なマクロを選び
[編集] ----> Visual Basicのダイヤログが開きます。
②[ツール] -->> [参照設定] --> 必要とするライブラリィにチェックを
いれて [OK]
Sub フォルダ参照W(SFolda As Variant)
'
'このサブルーチンを使用するときは、下記２行の設定と
'参照設定で Microsoft shell Controls And Automation の
'参照設定をすること。
'Private Const BIF_RETURNONLYFSDIRS As Long = &H1
'Private Const BIF_EDITBOX As Long = &H10
Dim myShell As Shell32.Shell
Dim myFolder As Shell32.Folder3
Dim myItem As Shell32.FolderItem
Set myShell = New Shell32.Shell
Set myFolder = myShell.BrowseForFolder( _
0&, "Excelブックの書込みフォルダを選択してください。" _
, BIF_RETURNONLYFSDIRS Or BIF_EDITBOX)
If myFolder Is Nothing Then SFolda = "": Exit Sub
MsgBox myFolder.Self.Path
SFolda = myFolder.Self.Path
Set myFolder = Nothing
Set myShell = Nothing
End Sub
--------------------------------------------------------------------
ダイヤログを表示し、参照したいフォルダのパス情報を取得するサブルーチン。
Sub フォルダ参照R(SFolda As Variant)
Set myShell = New Shell32.Shell
Set myFolder = myShell.BrowseForFolder( _
0&, "写真読込フォルダを選択してください。" _
, BIF_RETURNONLYFSDIRS Or BIF_EDITBOX)
If myFolder Is Nothing Then SFolda = "": Exit Sub
MsgBox myFolder.Self.Path
SFolda = myFolder.Self.Path
Set myFolder = Nothing
Set myShell = Nothing
End Sub
-----------------------------------------------------------------------
[書込み場所設定]ボタンクリックで書込み先のディレクトリー
を設定するサブルーチン。
Sub パス設定W()
'----------------------------------------------------
' パス設定
'----------------------------------------------------
フォルダ参照W SFolda
If SFolda = "" Then Exit Sub <---- フォルダの設定が無いときには、
強制終了にします。
書込み先のフォルダのパスを「マクロの表紙」のセル位置(3, 1)を書込みます。
Workbooks(AAname).Worksheets(CCname).Cells(3, 1).Value = SFolda
End Sub
-----------------------------------------------------------------------
[写真読込場所設定]ボタンクリックで写真読込先のディレクトリーを
設定するサブルーチン。
Sub パス設定R()
'----------------------------------------------------
' パス設定
'----------------------------------------------------
フォルダ参照R SFolda
If SFolda = "" Then Exit Sub <---- フォルダの設定が無いときには、
強制終了にします。
写真読込先のフォルダのパスを「マクロの表紙」の
セル位置(4, 1)を書込みます。
Workbooks(AAname).Worksheets(CCname).Cells(4, 1).Value = SFolda
End Sub
------------------------------------------------------------------------
写真の選択・貼付を実行するサブルーチン 2019.02.05 貼付け方法変更
Sub S写真選択(mm As Variant)
Dim fn As String
Dim F_array As Variant
Dim A_cnt, C_cnt, L_cnt As Integer
Dim Filename, Photname As String
Dim objShape As Shape
On Error GoTo S写真選択0: <---- ディレクトリの設定で、エラーが
発生したら強制的に貼り付け写真選択へジャンプさせる。
ユーザーフォームのオプションボタンのON(true)状態によって、
「マクロの表紙」の参照するセル位置を変える。
If Form2.CheckBox1 = False Then <---- 選択したセルへの貼付か？
With Form2
If .OB1 = True Then x2 = 2: y2 = 16
If .OB2 = True Then x2 = 3: y2 = 16
If .OB3 = True Then x2 = 4: y2 = 16
End With
写真を貼付けるセル位置データを取得する。
' 写真貼付位置取得
y = Workbooks(AAname).Sheets(CCname).Cells(y2, x2).Value
x = Workbooks(AAname).Sheets(CCname).Cells(y2 + 1, x2).Value
ActiveSheet.Cells(y, x).Select <---- 指定されたセルを選択する。
End If
写真データの保存先パス
ADir = Workbooks(AAname).Worksheets(CCname).Cells(4, 1).Value
If ADir <> "" Then
If Left(ADir, 2) = "\\" Then
' ネットワークドライブの参照
Call SetCurrentDirectory(ADir) <---- ネットワークドライブの参照
Else
ChDrive Left(ADir, 2) <---- PC内ドライブの参照
ChDir ADir
End If
End If
' 写真一覧のダイヤログを表示し、写真を選択させる。
myFname = Application.GetOpenFilename("画像ファイル(*.JPG;
*.BMP;*.GIF;*.WMF),*.JPG;*.BMP;*.GIF;*.WMF")
キャンセルの時・写真が選択されなかったときは強制終了する。
If myFname = False Then mm = 0: Exit Sub <-- 未選択時の処理
If VarType(myFname) = vbBoolean Then _
mm = 0: Exit Sub <-- キャンセルの時の処理
'
'-----------------------------------------------------------------------
' 次読込の為のパスを記録する。
C_cnt = Len(myFname) ' 選択した写真のフルパス文字数
F_array = Split(myFname, "\") ' \ で分割して 配列 F_array に代入
A_cnt = UBound(F_array) ' 現在の大きさ(要素数)を調べます
CCC = F_array(A_cnt) ' 最後配列に写真名がある
L_cnt = Len(CCC) + 1 ' 写真名の文字数 + \ の分
' 読込側のパス設定( \写真名 分を取る処理 )
Workbooks(AAname).Worksheets(CCname).Cells(4, 1).Value = _
Left(myFname, C_cnt - L_cnt)
'---------------------------------------------------------------
' 2019.02.05 写真貼り付け方法を改良( 簡素化出来ました )
' 下記マクロが、アクティブセルに張り付く事に注目しました。
' Left:=Selection.Left, Top:=Selection.Top でアクティブセルに貼付
' width:=Yoko, height:=Tate で貼付サイズ指定
'---------------------------------------------------------------
With Selection
Yoko = .width ' * 0.75 ' ピクセル単位
Tate = .height ' * 0.118 ' ピクセル単位
End With
If mm > 0 Then
'--------------- そのまま張付ける時の処理---------------------------
Set objShape = ActiveSheet.Shapes.AddPicture( _
filename:=myFname, _ <---- 挿入する写真ファイル名を
パス付きで指定
LinkToFile:=False, _ <---- False で独立した写真としての指定
True で元のファイルとのリンクを設定
SaveWithDocument:=True, _<---- True で Excelファイルと
共に保存 False でリンク情報だけを保存
Left:=Selection.Left, _ <---- アクティブセルの左端位置を指定
Top:=Selection.Top, _ <---- アクティブセルの上端位置を指定
Width:=yoko, _ <---- 張付け写真の横幅を指定
Height:=tate) <---- 張付け写真の高さを指定
写真表面に文字・図形が描けるように、表示順序を最背面にする。
width:=Yoko, height:=Tate)
'---------------------------------------------------------------
Else
'--------------- 90°回転する時の処理------------------------------
Set objShape = ActiveSheet.Shapes.AddPicture( _
Filename:=myFname, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Selection.Left - Tate / 2 + Yoko / 2, _ <-- 90°回転を考慮
して貼付け位置を補正しています。
Top:=Selection.Top + Tate / 2 - Yoko / 2, _ <-- 90°回転を考慮
して貼付け位置を補正しています。
width:=Tate, height:=Yoko)
補正値の計算方法については、[Excel 2007・2010・2013
対応マクロの勉強室 ]の [1. 写真の貼付けをする]で詳しく解説しています。
With objShape
' 写真の回転は、センターを基準にして回転するので
' その分張付けるときに補正をして貼付回転をする。
' 用紙からはみ出すと移動しないので考慮が必要。
'
.Rotation = 90
End With
'---------------------------------------------------------------
End If
objShape.ZOrder msoSendToBack <---- 張付けた写真の上に
文字・線等が書けるように、写真の表示順序を最背面にします。
Exit Sub
エラー時の処理
S写真選択0:
M = Err.Number
If M = 75 Then _
MsgBox ("設定されているフォルダのパス名は、無効です。")
If M = 76 Then _
MsgBox ("設定されているフォルダのパス名は、間違っています。")
End Sub
-----------------------------------------------------------------------
ドラックされたセルに指定された文字列(変数 : 文字)を書き込むサブルーチン
Sub S繰返(文字 As String)
ドラック範囲を取得する。
With ActiveWindow.RangeSelection
y1 = .Columns.Column
y2 = .Columns(.Columns.Count).Column
x1 = .Rows.Row
x2 = .Rows(.Rows.Count).Row
End With
ドラック範囲に変数 : 文字の内容を書き込む。
With ActiveSheet
x = x2 - x1: y = y2 - y1
If x = 0 And y = 0 Then
.Cells(x1, y1) = 文字 <---- セル一箇所に書き込む。
ElseIf x = 0 And y > 0 Then
For I = 0 To y
.Cells(x1, y1 + I) = 文字 <---- 横方向のセルだけに書き込む。
Next I
ElseIf x > 0 And y = 0 Then
For I = 0 To x
.Cells(x1 + I, y1) = 文字 <---- 縦方向のセルだけに書き込む。
Next I
ElseIf x > 0 And y > 0 Then
For I = 0 To x
For II = 0 To y
.Cells(x1 + I, y1 + II) = 文字 <---- 縦横方向のドラックされた
Next II セルに書き込む。
Next I
End If
End With
End Sub
------------------------------------------------------------------
シート名に枝番号を付けてシートコピーをするサブルーチン
Sub シートコピー()
'
N = Worksheets.Count <---- シートの数を取得する。
If N = 1 Then <---- シートが一枚の時は、そのシート名を取得し、
追加シート名に、"-1" を付けてシート名とする。
BBB = ActiveSheet.Name
AAA = ActiveSheet.Name & "-1"
ActiveSheet.Name = AAA
AAA = BBB & "-" & CStr(N + 1)
Else <---- シートが複数枚の時の処理
Worksheets(N).Activate
mm = ActiveSheet.Name
SS = Len(mm): BBB = Left(mm, SS - 2) <-- シート名の枝番を削除
AAA = BBB & "-" & CStr(N + 1) <-- 追加シート名に、"-n" を付けて
End If シート名とする
Application.DisplayAlerts = False <-- 警告メッセージをオフにする
mm = ActiveSheet.Name
Sheets(mm).Copy After:=Sheets(mm) <-- シートを後ろへコピーする
CCC = ActiveSheet.Name
' シートの下にページ数を書き込む
ActiveSheet.Cells(44, 1).Value = CStr(N + 1)
Worksheets(CCC).Name = AAA <-- シート名を変更する
Application.DisplayAlerts = True <-- 警告メッセージをオンにする
End Sub
-----------------------------------------------------------------------
選択された図形位置・サイズを表示するサブルーチン
Sub 図形位置サイズ()
'
Dim x1, y1 As Single
Dim x2, y2 As Single
With Selection
x1 = .Left
y1 = .Top
x2 = .Width
y2 = .Height
End With
MsgBox " 左 " + Format(x1, "#,##0") + " 上 " + Format(y1, "#,##0") _
+ " 横幅 " + Format(x2, "#,##0") + " 縦幅 " + Format(y2, "#,##0")
End Sub
-----------------------------------------------------------------------
(おまけ)Excelを開くダイヤログを表示し、
選択されたファイルを開くサブルーチン
Sub EXCELファイル読込()
Application.DisplayAlerts = False
myFname = _
Application.GetOpenFilename("EXCELファイル(*.xlsx),*.xlsx")
'
Workbooks.Open Filename:=myFname
Application.DisplayAlerts = True
End Sub
-----------------------------------------------------------------------
(おまけ)指定されたセル位置に、赤○を書き込むサブルーチン
Sub 丸描き()
'
Dim x1, y1, N, Msize, MXsize, Wsize, Ssize, Xsize, Ysize As Single
Dim SS, name1, name2 As String
On Error GoTo 丸描き1end:
With Selection
x1 = .Left
y1 = .Top
End With
' ○を描きます
ActiveSheet.Shapes.AddShape(msoShapeOval, x1, y1, 24.8, 24.8). _
Select
Selection.ShapeRange.Fill.Visible = _
msoTrue <--- これは、入れてください
' パターンなどが入っていない種類の塗りつぶしのこと
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 65 <-- 塗りつぶし
前景色 65 : 無地
Selection.ShapeRange.Fill.Transparency = 1# <--- 塗りつぶし透明度
0(不透明)～1(透明)
Selection.ShapeRange.Line.Weight = 1# <-- 線の太さ
Selection.ShapeRange.Line.DashStyle = msoLineSolid <-- 線の種類:実線
Selection.ShapeRange.Line.Style = msoLineSingle <-- 実線の種類:一本線
Selection.ShapeRange.Line.Transparency = 0# <-- 線の透明度
0(不透明) ～ 1(透明)
Selection.ShapeRange.Line.Visible = msoTrue <-- これは、入れてください
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10 <-- 線の色:赤指定
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255) <-- 線の
背景色:白
丸描き1end:
End Sub
-----------------------------------------------------------------------
張付けた写真のサイズ・位置等の変更を禁止するサブルーチン
Sub 写真変更禁止(Lock_Hani As Variant)
Dim Abc As Single
' いきなり実行するのではなく、確認をしてから実行します。
Abc = MsgBox("このページの写真変更禁止を設定します。", _
vbYesNo, "写真変更禁止確認")
If Abc = vbNo Then Exit Sub <---- Noの時終了
'----------------------------------------------------------------
ActiveSheet.Unprotect <-- 一度シート保護を解除します。
Cells.Select <-- シート全体を選択します。
Selection.Locked = _
False <-- シート全体のセルの保護ロックフラグをOFFする
' Lock_Hani で定義されたセル範囲を保護する。
' 写真を張付けたセル範囲を選択します。
Range(Lock_Hani).Select
Selection.Locked = _
True <---- 選択されたのセルの保護ロックフラグをONする
ActiveSheet.Protect userinterfaceonly:= _
True <---- マクロからの書換は、可能にする
Range("A1").Select <-- セル選択の解除
MsgBox ("写真変更禁止完了") <-- 終了メッセージ
End Sub
|
|
