読者です 読者をやめる 読者になる 読者になる

役に立つか?VBAメモ

仕事で使ったVBAをメモっとく

自動で名前の付いたシートを作成する

VBA Excel

先日、新規ブックを作成するにあたり、シートを16コ作らねばなりませんでした。
Sheet1の横にある【+】をポチポチクリックすればシート”だけ”は出来ますよ。
sheet2、sheet3、sheet4・・・・・sheet16ってね。
これをまた一つ一つシート名を変えていくのは面倒、と言うより辛い。
でも変えないと後々もっと面倒なことになることは分かってます。

そこでググってみよう!先駆者の知見を掠め取って、学んで見よう!

 

 

その1
VBAでシートを追加して、ついでに名前もリストから付けていってしまおうヽ(=´▽`=)ノ

①ブック作成
②sheet1の名前は取り敢えず【list】と名付けよう
③セルA1から順にA5までシートにつける名前を1セルにつき1つ記入しよう
④VBEで下記マクロ作成

Sub シート作成()
Dim SheetName As Range
For Each SheetName In Selection
Sheets.Add After:=Sheets("list")
ActiveSheet.Name = SheetName.Value
Next SheetName
End Sub

⑤マクロ実行

 

f:id:jus7733:20170112101538j:plain

このような感じでできあがりました。

でもなんか逆順(降順)じゃない?

これでも構わないのですが、ちょっと気持ち悪い。

 

 

その2
その1ではリストに対してシートが左から製品(n>4>3>2>1)ってなっててちょっとやだ(´・ω・`)
それなので単純に逆順でやればいい。

①ブック作成
②sheet1の名前は取り敢えず【list】と名付けよう
③セルA1から順にA5までシートにつける名前を1セルにつき1つ記入しよう
④VBEで下記マクロ作成

Sub シート作成2()
Dim SheetName As Range
Dim n As Long
n = 5
For Each SheetName In Sheets("list").Range("A1:A5")
Sheets.Add After:=Sheets("list")
ActiveSheet.Name = Sheets("list").Range("A" & n).Value
n = n - 1
Next SheetName
End Sub

⑤マクロ実行

 

f:id:jus7733:20170112101757j:plain

セルA1からの順送りではなくA5から遡っているだけ。
ただそれだけ。

左から昇順なので気分いい?

 

 

折角なので・・・


リストからシートを作成したので次はシート名を取得してリスト化するやつ。

①シート名を取得したいブックを開く
②シート【list】を追加作成
③下記マクロ作成

Sub シート名取得()
Dim SheetName As Object
Dim n As Long
n = 1
For Each SheetName In Sheets
Sheets("list").Range("A" & n).Value = SheetName.Name
n = n + 1
Next
End Sub

④マクロ実行
⑤シート【list】A1~にシート名一覧ができている、でしょ?

 

f:id:jus7733:20170112102006j:plain

 

単純なマクロですが、作業効率的には面倒さ加減が大分減るので良い!と思います。

大したことないと云えば、大したことないですがね。

 

 

一発範囲指定すりゃ、楽でしょう?

印刷範囲の設定をするときは、一般的に、
 範囲を指定して→ページレイアウトタブ→印刷範囲設定
やりますね。

ページごとに印刷するなら、
 ファイル→印刷→ページ指定
って具合かな?

 

仕事でこれやる時ってまず表なりが定型で作ってあって、値入れれば出来上がり、という場面が多いと思います、多分

1シート内でページごと、範囲ごとに異なる品種なり顧客なりの表など作ってあるのもよく見ます。

その度、必要なページだけ印刷するのに、冒頭のやり方をしているのが普通かな?

まあ違う方もいっぱいいるでしょうが。

 

兎に角、こんな方法はポチポチクリック回数ばかり多くて面倒です。
なので、シートの上部に(いやどこでもいいけど)ボタンを配置して、ボタンを押せば範囲指定をするようにします。

範囲の指定は【PageSetup.PrintArea】で行います。


例)ActiveSheet.PageSetup.PrintArea = "$A$1:$D$10"

セルA1からD10を範囲指定してます。
「""」のプロパティ値を長さ0("")にするとシート全体を指定することとなり、範囲指定が解除されます。


Private Sub CommandButton1_Click()

ActiveSheet.PageSetup.PrintArea = "$A$1:$D$10"

With Sheets("sheet2")
.Select
.PageSetup.PrintArea = "$A$1:$D$10"
End With

Sheets("sheet1").Select
Range("A1").Select

End Sub

Sheet1のA1からD10を範囲指定して、次いでSheet2のA1からD10も指定してます。
最後の2行で元のシートのA1を選択しました。
自動で元の位置に戻ってくれたほうがいいと思いますが、不必要なら削ってください。

 

Private Sub CommandButton2_Click()

ActiveSheet.PageSetup.PrintArea = ""

With Sheets("sheet2")
.Select
.PageSetup.PrintArea = ""
End With

Sheets("sheet1").Select
Range("A1").Select

End Sub

範囲選択解除です。


後は範囲指定毎にボタン(マクロ)を追加していけばいいです。

なんてことはないんですけど、便利です。

 

 

恵川商事 アカパックン 洗濯用 ピンク

恵川商事 アカパックン 洗濯用 ピンク

 

 

これでいい選択ができるよ。

(-_-;)(;-_-) チガウチガウ

Excelのセルはコピペでシェイプ(図形)になるんです

Excel

VBAじゃないけど。

 

Excelで既定の文字入りシェイプって少ないじゃないですか?

でも、セルに入力した値をセルごとシェイプ化できるんですよ。

これは結構便利だと思うんだけどなぁ

 

f:id:jus7733:20160527163202p:plain

セルに値(文字)を入れます。行列の幅高さを合わせておくと綺麗に仕上がります。

 

f:id:jus7733:20160527163310p:plain

適当なシェイプを用意します。なんでもいいです。

 

3

f:id:jus7733:20160527163355p:plain

値のセルをコピーします。

 

4

f:id:jus7733:20160527163441p:plain

シェイプの上にペーストします。

 

5

f:id:jus7733:20160527163552p:plain

コピー元のセルの上にシェイプが出来上がってます。

 

6

f:id:jus7733:20160527163639p:plain

わかりやすくするのに枠線消して、大きくもしてみました。

枠線もシェイプに含まれてますので、分かりやすいですね。

 

枠線を入れたくない場合は、値をコピーする前に[表示]タブを開き枠線のチェックを外し非表示にしましょう。

 

なんてこと無いんですが、知らない人多いみたいなんで。

 

 

 

Spoolerが起きてこないので無理やり起こす

batなど

WIN10にしてからなのか、その前の7の時からなのか覚えていないがwindowsサービスのPrintSpoolerを自動に設定していても起動してこない。

一度は起動していても印刷最中とかに突然お眠りになる。

管理ツールからいちいちサービス管理呼び出すのも名前を〜で呼び出すのもかったるい。

なんせ自分の使うPCでなく同僚(女の子)のなんで、呼ばれるのは嬉しいが、上記手続きは嫌。

で、バッチ作ってお呼ばれしたらさくっと直してしまおうという魂胆です(^_^;)

 

@echo off

set ServiceName=Spooler

net start  | find /i "%ServiceName%"

if %errorlevel%==0 (

   goto kanryo

) else (

   goto mokkai

)

:mokkai

net start %ServiceName%

if %errorlevel%==0 goto kanryo

rem エラー処理とか書くといいさ

:kanryo

(これ書いてるのmacwindowsで試してないから間違いあるかも?)

ServiceName=サービス名 にすればいろんなサービスに転用可のう・・・ん?

 もっと簡単にコレでいいじゃん・・・1行だ。

net start Spooler

で良いさ。

考えすぎだったな。

因みに止めるには net stop サービス名

止めて起動すれば再起動の動作です。

ただし、いずれにせよバッチは管理者権限で実行することが必要です。

やはり面倒なので、バッチファイルのショートカット作ってプロパティで管理者権限で実行にチェック入れてしまえばクリックひとつで実行できます。

 

注意!!

根本対策じゃないんで、あなたはちゃんとPCを直しましょうw

私は彼女のPCを直しませんが!なにか問題でも?

肥大化したExcelファイルを整理する

Excel VBA

同僚が「このファイル、コピペするのにすごく時間がかかって応答しなくなる。」
というので、覗いてみたところファイルサイズが4MB弱あった。
内容はどう見積もっても500KB弱程度のはず・・・
シートが50個程度で、データ数は1シート100~500ぐらい。

で、最初に考えたのが図形を大量に入れてないか?でしたが、見ても見当たらない。
”編集”-”検索と選択”-”オブジェクトの選択と表示”とやってみると・・・
出るわ出るわでズラーっとリストアップされました、TextBoxが!しかも枠線なし!
見えないはずですよ~
とても数えられないので、VBEで以下を記述、実行。

Sub shapescount()
MsgBox ActiveSheet.Shapes.Count
End Sub

出ました。
その数3万弱(゚д゚)!

コピペコピペを繰り返し、7年間コツコツ集めたんですねw
削除には以下を記述して実行。

Sub del()
ActiveSheet.Shapes.SelectAll
Selection.Delete
End Sub

Selection.Deleteで何故かつまってしまうので、セレクトしたところで手動削除しました。
これらを各シートで実行し、全てのシェイプを削除しました。

が!がががが、まだ3MB弱のファイルサイズ。
なんで??

あるシートでCtrl+Shift+Endをやってみたところ、最終セルは2500行目あたり。
勿論データはそんなところには入っていない。一方、列は正常。

この異常な最終セルの設定が真犯人だったようで、約50シートの余分なセルを削除して上書き保存すると・・・
ファイルサイズは440KBになりました。

目視確認できないシェイプとコピペ乱用、シートの複製・列の挿入削除の乱発は面倒なことになるという教訓でした。
めでたしめでたしw

ん?ななねんかん?年度ごとにファイル分けてる・・?
ああ、やや少ないものの後6ファイル同様なのがあるんだ・・・・(´・ω・`)

添付ファイル付きで署名入れてメールする

Excel VBA

前回エクセル表をPDFにしました。

このPDFは、客先に送付しなきゃいけないものなんです。

これがまた面倒・・・

もう本文は定形だし、宛先も固定なんでいっそVBAでやっちまおうと。

Outlookの挙動は

 

jus7733.hatenablog.com

 ほぼ同じです。

ただ、署名を入れるのに若干苦労しました。

署名を

SendKeys "%N"
SendKeys "^AS"
SendKeys "{ENTER}"
で入れようとしたら、本文よりも上に署名されたのでかなり困りました。

それで検索したところ、

VBAでOutlookの署名を本文に挿入 - ClockAhead 開発Blog

こちらからご教授頂きましたぁ

で、出来たのが以下。

'//
Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

 '署名のテキスト全文の読み出し

Public Function ReadAllText(fileName As String)
Dim fso As Object, buf As String
Set fso = CreateObject("Scripting.FileSystemObject")
With fso.GetFile(fileName).OpenAsTextStream(1, -2)
buf = .ReadAll
.Close
End With
Set fso = Nothing

ReadAllText = buf
End Function


Private Sub CommandButton1_Click()
Dim oApp As Object
Dim myNameSpace As Object
Dim myFolder As Object
Dim objWShell As Object
Dim flg As Boolean
Dim hwnd As Long

Const FCLASSNAME As String = "rctrl_renwnd32"

On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set oApp = CreateObject("Outlook.Application")
flg = True
End If

On Error GoTo 0

If flg Then
Set myNameSpace = oApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(6)
myFolder.Display
oApp.ActiveWindow.WindowState = 2

Else
Set objWShell = CreateObject("WScript.Shell")
objWShell.AppActivate oApp.ActiveWindow.Caption
hwnd = FindWindow(FCLASSNAME, vbNullString)
SetForegroundWindow hwnd

End If

'ここからメールの作成
Dim myItem
Dim Ffldr As String
Dim Fname As String
Dim sin As String

Ffldr = "C:\Users\ユーザ名\Documents\検査成績書\PDF\"
Fname = Ffldr & Range("A11") & Format(Range("B6"), "【yymmdd】") '添付ファイルの用意

sin = ReadAllText("C:\Users\ユーザ名\AppData\Roaming\Microsoft\Signatures\署名.txt") '署名の用意

Set myItem = oApp.CreateItem(0)


myItem.Display

myItem.Subject = "検査表を送付いたします"
myItem.To = "atesakiA@ex.com ;atesakiB@ex.com" '宛先は;で区切り
myItem.Body = "株式会社○○ 御中" & vbCrLf & "" & vbCrLf & "お世話になっております。" & vbCrLf & "検査表を送付いたします。" & vbCrLf & vbCrLf & sin

myItem.Attachments.Add Fname & ".pdf" 'PDFを添付します

'追加動作
'myItem.Save '.Saveで保存下書きへ
'myItem.Send '.Sendで送信

End Sub

 エラー処理は全部やってないです。

しくじっても.SendはOFFしてるんで怪我しませんし(^_^;)

よくわからないこともあるけど動くからいいか!

 

 

ExcelでPDF作成

Excel VBA

エクセルでPDFは普通に作成できます。

ファイルーエクスポートでPDF/XPSの作成ボタンを押すだけ。

でも好きなようにファイル名を付けようとすると一々名前を打ち込まないといけない。

面倒だ・・・・

なので、以下。

 

検査表をエクセルで作ってPDF化するのですが、セルA11に検査対象品名セルB6に日付が入っているものとします。

Sub PDF作成_Click()
Dim Ffldr As String
Dim Fname As String

Ffldr = "C:\Users\ユーザ名\Documents\検査成績書\PDF\"
Fname = Ffldr & Range("A11") & Format(Range("B6"), "【yymmdd】")

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=Fname _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End Sub

ドキュメントフォルダの検査成績書内PDFフォルダに作成します。

ファイル名は検査対象品名【日付】となっています。

単にマクロの記録で用意して、少し弄っただけですけど^^;