FC2ブログ

選択したシートを全て削除するマクロ

2017–05–21 (Sun) 13:47
<選択したシートを全て削除する>
Sub 選択シートの削除
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
For Each s In ActiveWindow.SelectedSheets
s.Delete
Next s

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

Eud Sub

選択したオートシェイプを「黒実線」「塗りつぶしなし」にするマクロ

2017–05–20 (Sat) 11:38
sub オートシェイプ
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 0.5
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
End With
End sub

オートシェイプは作ると変な色で作成されるため、毎回修正しなければなりません。
それを自動で直してくれます。

日付マクロ

2017–05–20 (Sat) 11:22

activecell.NumberFormatLocal = "yyyy""年""m""月""d""日"";@
実行するとアクティブセルを2014年1月1日形式で表示します

activecell.NumberFormatLocal = "yyyy/m/d;@
実行するとアクティブセルを2014/1/1形式で表示します

activecell.NumberFormatLocal = "yyyy;@
例:形式(2014年)

activecell.NumberFormatLocal = "ge"".""m"".""d"""";@"
実行するとアクティブセルをH25.1.1形式で表示します。

activecell.NumberFormatLocal = "[$-411]ggge""年""m""月""d""日"";
実行するとアクティブセルを平成25年1月1日形式で表示します

activecell.NumberFormatLocal = "ggge;@
形式(ggge年/平成27年)

selection.NumberFormatLocal = "e;@"
形式(e/27)

メインで使うのはこの辺りだと思います。

あらたな最適化

2017–05–19 (Fri) 14:55
Sub 最適化()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
For Each s In activeworkbook.sheets
s.Activate
On Error Resume Next
With s.UsedRange
maxrow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
maxcol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim test
test = Range(s.Cells(1, 1), s.Cells(maxrow, maxcol))
Range(s.Cells(1, 1), s.Cells(maxrow, maxcol)) = test
Range(s.Cells(1, 1), s.Cells(maxrow, maxcol)).Interior.ColorIndex = xlNone
On Error GoTo 0
On Error Resume Next
Dim obj As OLEObject
'Selects all ActiveX controls on the active sheet and deletes them
For Each obj In s.OLEObjects
obj.Delete
Next obj

On Error GoTo 0

On Error Resume Next
s.Cells.SpecialCells(xlCellTypeComments).ClearComments
On Error GoTo 0

On Error Resume Next
Dim shp As Shape

For Each shp In s.Shapes

If shp.Type = msoGroup Then
has_grp = True
shp.Ungroup
Else
has_grp = False
End If

Next shp

For Each shp In s.Shapes

If shp.Visible = msoFalse Then
shp.Delete
End If
shp.Select
If Selection.PrintObject = msoFalse Then
shp.Delete
End If
Next shp

On Error GoTo 0

On Error Resume Next
s.Cells.Validation.Delete
On Error GoTo 0

On Error Resume Next
s.Cells.FormatConditions.Delete
On Error GoTo 0


Next

Dim n As Name
If activeworkbook.names.count < 1000 Then
For Each n In activeworkbook.names
On Error Resume Next ' エラーを無視
If InStr(n.Name, "Print") = 0 Then
n.Delete
End If
Next
End If

On Error GoTo 0
Dim myWb As Workbook

Set myWb = activeworkbook
On Error Resume Next

For Each myname In myWb.names
With myname
.Visible = True
If InStr(1, .RefersTo, "REF") _
+ InStr(1, .RefersTo, "N/A") _
+ InStr(1, .RefersTo, "\") _
+ (InStr(1, .RefersTo, "$") = 0) Then .Delete
End With
Next
On Error GoTo 0

For Each mySh In Worksheets
mySh.AutoFilterMode = False
Next

For Each ws In Worksheets
ws.Tab.ColorIndex = xlNone
Next ws



For Each mySh In Worksheets
mySh.AutoFilterMode = False
Next

Dim myVBComp
For Each myVBComp In activeworkbook.VBProject.VBComponents
If myVBComp.Type = 100 Then
'Documentモジュール(ThisWorkbokやSheet)なら消去
With myVBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
Else
'Documentモジュール(標準モージュール、クラスモジュール、Formなど)以外なら削除
Application.VBE.ActiveVBProject.VBComponents.Remove myVBComp
End If
Next myVBComp


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

印刷しないオートシェイプ・無駄な色なども削除してくれます。

最適化マクロ

2017–05–18 (Thu) 21:35
最新マクロは、最適化マクロです。
このマクロを実行する事により、式・名前の定義・マクロを削除します。
既に使用していない過去のデータや、過去の提出書類・前期の請求書等を最適化するために用いるマクロです。
(今使用する書類・書類の原紙・テンプレートへは実行しません)


高確率で最適化してくれます。



Sub 最適化()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
For Each s In activeworkbook.sheets
On Error Resume Next
With s.UsedRange
maxrow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
maxcol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim test
test = Range(s.Cells(1, 1), s.Cells(maxrow, maxcol))
Range(s.Cells(1, 1), s.Cells(maxrow, maxcol)) = test
Dim obj As OLEObject
'Selects all ActiveX controls on the active sheet and deletes them
For Each obj In ActiveSheet.OLEObjects
obj.Delete
Next obj

Dim shp As Shape

For Each shp In s.Shapes
If shp.Visible = msoFalse Then
shp.Delete
End If
Next shp
Next

Dim n As Name
If activeworkbook.names.count < 1000 Then
For Each n In activeworkbook.names
On Error Resume Next ' エラーを無視
If InStr(n.Name, "Print") = 0 Then
n.Delete
End If
Next
End If


Dim myVBComp
For Each myVBComp In activeworkbook.VBProject.VBComponents
If myVBComp.Type = 100 Then
'Documentモジュール(ThisWorkbokやSheet)なら消去
With myVBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
Else
'Documentモジュール(標準モージュール、クラスモジュール、Formなど)以外なら削除
Application.VBE.ActiveVBProject.VBComponents.Remove myVBComp
End If
Next myVBComp
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
最適化前

最適化前

最適化後

最適化後

減りました~

主任技術者-2

2017–05–17 (Wed) 23:27
主任技術者.xlsm

主任技術者-3

主任技術者-4

主任技術者-5

基準値をわかりやすくするために画像を追加致しました。
及び、名前を付けるマクロも登録致しました。

スタンプアドイン Excel2010対応

2017–05–16 (Tue) 16:56
はなかなアドイン

可愛いスタンプアドインです。

スタンプアドイン

Excel2010に対応しています。
申し訳ございませんが、他のエクセルに対応しているかは分かりません。

インストールすると、はなかなアドインがリボンに追加されます。

はなかなアドイン-2

ボタンをクリックすると対応するスタンプ画像が登場します。

はなかなアドイン-3

主任技術者

2017–05–16 (Tue) 07:42
主任技術者.slsx

主任技術者-1

主任技術者-2

今回も住所データと連携しています。
詳しい式などは開くと出て来ます、が、マクロがまだ入っていない状況です。

7ecd6b49.jpg

HyperLinkをマクロで作成する。

2017–05–14 (Sun) 14:57
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

運転免許証リストなどを作成するときに重宝しています。

VLOOKUPとINDEX&MATCH早いのはどちらか

2017–05–14 (Sun) 14:38
資格証を取得するさい、その番号・日付が必要な場合は
VLOOKUPよりもINDEXとMATCHを組み合わせた方が早く抽出することが出来ます。

以前に公開した=INDEX(資格番号1,MATCH("資格名",資格名,0))はとても計算が速い式となっています。
また、=IF(ISERROR(=INDEX(資格番号1,MATCH("資格名",資格名,0))),"",=INDEX(資格番号1,MATCH("資格名",資格名,0)))を
資格番号取得の式に入力し、隣りに
=if(資格番号取得の式を入れたセル="","",INDEX(資格取得日1,MATCH("資格名",資格名,0)))と入力することにより、
さらに早い計算を求めることも出来ます。

今回さらにパワーアップした資格証式を公開致します!

入構書類.NET 資格証&住所データ Match式対応-2.xlsm

式説明

VLOOKUPは使う人が多いですが、時間がかかるため、お勧めしません。
弊社で計測した結果、「INDEX+MATCH」と「OFFSET+MATCH」を組み合わせた物は20シートほどの計算でもわずか0.09秒で終わりました。
VLOOKUPを使用したものは最短で0.97秒、時間がかかる際は5秒~10秒かかる場合もありました。

« 前へ | HOME |  次へ »

プロフィール

はる

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

最新記事

最新コメント

フリーエリア

月別アーカイブ

カテゴリ

ブロとも申請フォーム

検索フォーム

RSSリンクの表示

リンク