FC2ブログ
エホバの証人二世の、個人研究&趣味blogです。
2019/07«│ 2019/08| 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 »2019/09
文字色の変化のON/OFFが出来ます。文字サイズ文字サイズ:大文字サイズ:中文字サイズ:小
19:56:02
館殺人事件を最近ずっと読んでいます。
後はハヤテのごとく!を見たりしています。それ以外にもうたプリをプレイしたり、大学勉強をしたり、マクロを作成したりしています。
ピアノの譜読みもありますし。月光の第三楽章って難しいですね。
後はゆっくりとしています……。
「魔界塔士saga」と言うゲームをプレイすることになりました~~~。



ピアノロールで弾いても難しいですよね。

お気に入りファイル・お気に入りシート・お気に入りセルを登録します。
お気に入りセルは起動しているのみ使用出来ます。

お気に入り.xlsm

お気に入りアドイン

これは明日から仕事で使います。
21:57:06
今回は必要な枚数のワークシートを自動で作成し、非表示設定も自動で行ってくれますマクロです。
事前に、アドイン等に必要書類リストを登録しておくと更に使いやすくなります。


必要ワークシート登録

必要ワークシート登録-2

必要書類リスト.xlsm



あああ譜読みはじめないと5月末にピアノソナタ弾けなくなってしまう。
譜読みは私の場合楽譜を打ち込みながらしていきます。
今回ベートーヴェン「ピアノソナタ第14番」を全楽章弾く予定です!



第三楽章弾けるかなぁ~~~♪
譜読みは三日で終わるとしても……
17:32:48
Shape アドイン

汎用性の高いオートシェイプのアドインを作りました。
次は「はな金銭管理」を作ろうと思います。
所属先で金銭管理も任されるようになりまして……。
頑張ろうと思います!
金銭管理は少しずつ追加していこうと思います。
16:21:43
アドインにワークシート関係の処理マクロを追加します。
・シートの削除
・アクティブシートのコピー
・アクティブシートのコピー(枚数指定)
・名前の変更(Inputbox・手入力)
・名前の変更(指定セルの値)
・名前の変更(現在のシート名+指定セルの値)・複数可能

以上の作業が可能となります。
そのままコピーしてエクセルマクロに貼り付ければ使用できます。


Application.CommandBars("Worksheet Menu Bar").Controls("シートのコピー・削除").Delete
Dim myWsMenu As CommandBar

Set myWsMenu = Application.CommandBars("Worksheet Menu Bar")

Set sheetcopydel = myWsMenu.Controls.Add _
(Type:=msoControlPopup, Temporary:=True)
sheetcopydel.Caption = "シートのコピー・削除"

Dim sheetdel As CommandBarButton
Set sheetdel = sheetcopydel.Controls.Add _
(Type:=msoControlButton, Temporary:=True)
sheetdel.OnAction = "シートを削除"
sheetdel.Caption = "シートを削除"

Dim sheet1copy As CommandBarButton
Set sheet1copy = sheetcopydel.Controls.Add _
(Type:=msoControlButton, Temporary:=True)
sheet1copy.OnAction = "アクティブシートをコピーする"
sheet1copy.Caption = "シートのコピー(1枚)"

Dim sheetcopy As CommandBarButton
Set sheetcopy = sheetcopydel.Controls.Add _
(Type:=msoControlButton, Temporary:=True)
sheetcopy.OnAction = "アクティブシート複数コピー"
sheetcopy.Caption = "シートのコピー(複数)"

Dim namechange As CommandBarButton
Set namechange = sheetcopydel.Controls.Add _
(Type:=msoControlButton, Temporary:=True)
namechange.OnAction = "ワークシート名変更"
namechange.Caption = "ワークシート名変更"

Dim namechange2 As CommandBarButton
Set namechange2 = sheetcopydel.Controls.Add _
(Type:=msoControlButton, Temporary:=True)
namechange2.OnAction = "ワークシート名変更2"
namechange2.Caption = "セルの値をシートへ"

Dim namechange3 As CommandBarButton
Set namechange3 = sheetcopydel.Controls.Add _
(Type:=msoControlButton, Temporary:=True)
namechange3.OnAction = "シート名名前を残して変更"
namechange3.Caption = "現在のシート名+セルの値(複数)"


Sub シートを削除()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each s In ActiveWindow.SelectedSheets
s.Delete
Next s
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub アクティブシートをコピーする()
Application.DisplayAlerts = False
ActiveSheet.Copy After:=ActiveSheet
End Sub

Sub アクティブシートを連番でコピーする()
Application.DisplayAlerts = False
kazu = ActiveSheet.Index
namae = ActiveSheet.Name
ActiveSheet.Copy After:=ActiveSheet
Worksheets(kazu + 1).Name = namae & "-2"
End Sub

Sub ワークシート名変更()
Dim namae As String
namae = InputBox("名前入力")
If namae <> "" Then
ActiveSheet.Name = namae
End If
End Sub

Sub ワークシート名変更2()
Dim namae As String
Set buf2 = Application.InputBox(Prompt:="セルを選択してください。", Type:=8)
If buf2.Value <> "" Then
ActiveSheet.Name = buf2.Value
End If
End Sub



Sub シート名名前を残して変更()

Set buf2 = Application.InputBox(Prompt:="セルを選択してください。", Type:=8)
Application.ScreenUpdating = False
Dim kazu As Long
buf2 = buf2.Address
If InStr(ActiveSheet.Name, " (") <> 0 Then
myFind = Left(ActiveSheet.Name, InStr(ActiveSheet.Name, " (") - 1)
Else
myFind = ActiveSheet.Name
End If

For Each ws In activeworkbook.Worksheets
On Error Resume Next

If InStr(ws.Name, myFind) <> 0 Then
kazu = kazu + 1
End If
Next ws


For Each ws In activeworkbook.Worksheets
On Error Resume Next

If InStr(ws.Name, myFind) <> 0 Then
If kazu = 1 Then
ws.Name = myFind & "(" & ws.Range(buf2) & ")"
ElseIf InStr(ws.Name, "(") <> 0 Then
ws.Name = myFind & "(" & ws.Range(buf2) & ")"
End If
End If
Next ws



Application.ScreenUpdating = True
End Sub
11:39:30
1.検索したい言葉を含むファイルが一つの場合。

sub ハイパーリンクの作成
Const cnsDIR = "\*.*"
Const cnsTitle = "フォルダ内のファイル名一覧取得"

If VarType(vntPathName) = vbBoolean Then Exit Sub
strPathName = 検索アドレス
' フォルダの存在確認
If Dir(strPathName, vbDirectory) = "" Then
End If

strFileName = Dir(strPathName & cnsDIR, vbNormal)
' ファイルが見つからなくなるまで繰り返す
mitsu = 0

Do While strFileName <> ""
If InStr(strFileName, 検索したいファイル名) <> 0 Then

ActiveSheet.Hyperlinks.Add Anchor:=activecell, Address:=strPathName & "\" & strFileName

mitsu = 1
End If

strFileName = Dir()

end sub

※ 検索アドレス・検索したいファイル名を変更したら即使用できます。
※ アクティブセルが空白の場合はアドレスがそのまま入ります。

まず、特定のフォルダを読み込みます。
その後全てのファイルを読み込んで行きます。
ループ内で検索したいファイル名を見つけたら、ハイパーリンクを作ってくれます。
非常に単純なマクロですが、一覧表を作る時などに重宝するマクロとなっています。
プロフィール

はなかな

Author:はなかな
FC2ブログへようこそ!

最新記事
最新コメント
月別アーカイブ
カテゴリ
フリーエリア
ランキング参加しています。 にほんブログ村 哲学・思想ブログ エホバの証人へ にほんブログ村 にほんブログ村 本ブログ 読書日記へ にほんブログ村 にほんブログ村 音楽ブログへ にほんブログ村
音楽(J-POP) ブログランキングへ
小説(読書感想) ブログランキングへ
キリスト教 ブログランキングへ
ブログランキング ブログ王ランキングに参加中!
検索フォーム
RSSリンクの表示
リンク
このブログをリンクに追加する
ブロとも申請フォーム

この人とブロともになる

QRコード
QR
FC2アフィリエイト