Excel VBA メモランダム

ExcelVBAメモランダム

VBA（マクロ）というと難しく考えがちですが、
「新しいマクロの記録」で実際の操作を記録させることで
簡単な繰り返し作業をさせることができます。
あと少し、「条件分岐」と「繰り返し処理」がちょっと理解できれば
あなたも立派なマクロ使いです。
また、Excel VBAに関するＨＰがたくさん存在し
質問にも答えてくれる方々が集うBBSなどもたくさんあります。

このメモランダム（備忘録）は、最近物忘れが多くなった私のために
以前に使ったちょっと便利な処理を集めました。

システムフォント

システムにインストールされているフォントの一覧を書き出します。
Mac エクセルでは動作確認をしていません。

Sub システムフォント()
Dim i

With Application.CommandBars("Formatting").Controls(1)

'A列にシステムフォント一覧を書き出す
For i = 1 To .ListCount
Cells(i, "A") = .List(i)
Next i
End With

End Sub

●サンプルダウンロード　【システムにないフォント検索】　

ワードでは「オプション」－「互換性」－「フォントの置換」でインストールされていないフォントが使われているデータのフォントのチェックができます。
しかし、エクセルではワードのようにシステムにインストールされていないフォントが使われている「他のＰＣ等で作成されたブック」のフォントのチェックができません。
そのぞれのセル・テキストボックス・ワードアートを一文字ずつフォント名を取得し、それを「システムフォント」と比較して「システムにないフォント名」を取得しています。

ユーザーフォームモードレス

規定値ではユーザーフォームを表示中は、エクセルの操作はできません。
引数（vbModeless or 0 or False）を付けてモードレスで表示させることで、ユーザーフォーム表示中でもエクセルの操作をすることができます。

UserForm1.Show vbModeless
UserForm1.Show 0
UserForm1.Show False
　

Sub 特色Color()
UserForm1.Show False
End Sub

●サンプルダウンロード　【CMYK値→特色番号検索】

Photoshopの「カラーピッカー」で、該当するCMYK値を入力し、カスタムカラーを「DIC カラーガイド」に変更するとDIC色番号の近似色が選択されるという方法を試してみましたが、Potoshopで一番近いと判断された特色番号が一つしか選択されません。

Illustrator 8 のスウォッチライブラリにある「DICCOLOR.ai」「FOCOLTONE.ai」「PANTONE Coated.ai」「PANTONE Process.ai」「PANTONE Uncoated.ai」「TOYO.ai」「TRUMATCH.ai」からCMYK値を抜き出しデータを作成し、それぞれの色が±10％の範囲までの特色番号を検索します。
当然といえば当然だがバージョンが新しくなるにしたがってスウォッチライブラリのデータが少しずつ増えているようです。
Illustrator CS に付属の PANTONE９種類のデータを追加しました。
ユーザーフォームをモードレスで表示させることで、ユーザーフォーム実行中でもSheetを変更したり、Bookを変更したりとエクセルの操作ができるようになります。

文字列検索

下の例は、A列から「検索文字列」にヒットした行を選択します。
うまく応用すればLookup関数処理のような使い方ができます。

Sub 文字列検索()

Dim FoundCell As Range
Dim FoundChr

FoundChr = InputBox("検索文字列")

'A列を選択
Columns("A:A").Select

Set FoundCell = Selection.Find(What:=FoundChr)　　　'検索オプションを変更できる

If Not FoundCell Is Nothing Then　　　'見つかった場合
    FoundCell.Select
    MsgBox ActiveCell.Row & " 行目を選択しました。"
Else
    MsgBox "見つかりませんでした"
End If

End Sub

オートフィルタでのコピー

オートフィルタを実行して必要な行を別シートにコピー貼り付けすることは結構あると思います。
しかし、オートフィルタが実行されている状態では行単位の「コピー」、別シートへの「貼り付け」をすると「表示されている列・行」のみとなり、「計算式」などは「値」でコピーされてしまいます。
マクロだけではなくオートフィルタを実行中は同一シート上では行単位の「貼り付け」もできません。
■計算式を残し、隠れた列も表示させ、必要な行を別シートにコピーするにはどうしたらいいか？
  (1)シートをコピーして必要以外の行をオートフィルタで選択し、削除する。
  (2)オートフィルタで必要な行を選択し、その行番号を控えておいて後でオートフィルタを解除してその行番号のみを複写する。
  (3)最初からオートフィルタを使わず、マクロの条件式等でその行を検索して複写する。
    などの方法が考えられます。
■SendKeysステートメントを使ってキーコードを入力すれば、オートフィルタで表示されていない行があっても１行ずつカーソルを移動できます。

Sub 非可視行削除()

Rem オートフィルタ実行中でも行削除できる。
Rem ただし、行番号の多いほうから削除しないと行番号がずれてしまう。

Dim lastrow, hid

'最終行取得
With ActiveSheet.UsedRange
    lastrow = .Cells(.Count).Row
End With

For hid = lastrow To 1 Step -1
    Rows(hid & ":" & hid).Select
'表示しない行ならば削除
    If Selection.EntireRow.Hidden = True Then Selection.Delete Shift:=xlUp
'行の高さが0ならば削除
    Rem If Selection.RowHeight = 0 Then Selection.Delete Shift:=xlUp
Next hid

End Sub

Sub キー入力()

Dim i

Range("A1").Select

For i = 1 To 10
SendKeys "{DOWN}", True
Next

End Sub

選択範囲のサイズ取得

選択範囲のサイズをポイントとミリの単位で取得します。

Sub 選択範囲のサイズ()

Dim p2m
Dim yoko, tate

Range("A1:E2").Select
MsgBox ("Range(""A1:E2"")を選択しました")

p2m = 2.8346455 'pointからmmへ

yoko = Selection.Width
tate = Selection.Height

MsgBox (Int(yoko * 100) / 100 & " × " & Int(tate * 100) / 100 & " (pt)" & Chr(13) & _
Int(yoko / p2m * 100) / 100 & " × " & Int(tate / p2m * 100) / 100 & " (mm)")

End Sub

最終アドレス取得

最終データ行（列）まで繰り返し処理をさせたい場合、最終行（列）のアドレスを取得します。

Sub 最終アドレス取得()
Dim lastrow
Dim lastcol

'最終行取得
With ActiveSheet.UsedRange
lastrow = .Cells(.Count).Row
End With

'最終列取得
With ActiveSheet.UsedRange
lastcol = .Cells(.Count).Column
End With

MsgBox ("最終行　" & lastrow & Chr(13) & "最終列　" & lastcol)
End Sub

画面非表示

画面表示させないことで処理時間を短縮させることができます。

Sub 画面非表示()
Dim i, j

Application.ScreenUpdating = False

'作業はじめ
Sheets.Add
For i = 1 To 256
    For j = 1 To 256
        Cells(i, j) = i * j
    Next j
Next i
'作業おわり

Application.ScreenUpdating = True
MsgBox "おわり"
End Sub

ステータス表示

「Application.ScreenUpdating = False」で画面表示させないことで処理時間を短縮させることができるが、進行状況をステータスに表示させる。

Sub ステータス表示()
Dim i

'ステータス設定
Application.StatusBar = "画面表示"
Application.DisplayStatusBar = True

MsgBox ("ステータスに進行状況を表示します")

Application.ScreenUpdating = False '画面非表示

For i = 1 To 10000
Cells(i, 1) = i
'ステータス設定
Application.StatusBar = 10000 - i & " 行を処理中"
Next i
Cells(10000, 1).Select

MsgBox ("OK?")

'ステータスを戻す
Application.StatusBar = False
Application.ScreenUpdating = True '画面表示

End Sub

パスと区切り

読み込んだブックのパスやアクティブなブックやシートの名前を取得できます。

Sub パスと区切り()
Dim MyPath
Dim Kugiri
Dim datechr
Dim timechr
Dim savefilename
Dim actsheet
Dim actbook

'アクティブなbook nameの取得
actbook = ActiveWorkbook.Name

'アクティブなsheet nameの所得
actsheet = ActiveSheet.Name

'起動したパスの取得
MyPath = ActiveWorkbook.Path

'パスの区切りの取得（Win="\"）
Kugiri = Application.PathSeparator

'日付（date）の右８桁を取得し"/"を削除
datechr = Replace(Right(Date, 8), "/", "")

'時刻（time）の左８桁を所得し":"を削除
timechr = Replace(Left(Time, 8), ":", "")

'日付と時刻を組み合わせたファイル名を作成
savefilename = MyPath & Kugiri & actbook & datechr & "_" & timechr & ".xls"
Range("A2") = Date
Range("A3") = Time
Range("A5") = savefilename

MsgBox (savefilename)

Rem ActiveWorkbook.SaveAs Filename:=savefilename

End Sub

セルのアドレス取得

セルのアドレスを取得する方法はいくつかあります。
処理の種類・用途によって使い分けると便利です。

Sub セルのアドレス取得()

Range("D3").Select
MsgBox ("Range(""D3"")" & " を選択しました")

MsgBox ("ActiveCell.Row " & ActiveCell.Row & " ActiveCell.Column " & ActiveCell.Column)

MsgBox ("ActiveCell.Address()" & Chr(13) & ActiveCell.Address())

MsgBox ("ActiveCell.Address(RowAbsolute:=False)" & Chr(13) & _
ActiveCell.Address(RowAbsolute:=False))

MsgBox ("ActiveCell.Address(ColumnAbsolute:=False)" & Chr(13) & _
ActiveCell.Address(ColumnAbsolute:=False))

MsgBox ("ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)" & Chr(13) & _
ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False))

MsgBox ("ActiveCell.Address(ReferenceStyle:=xlR1C1)" & Chr(13) & _
ActiveCell.Address(ReferenceStyle:=xlR1C1))

End Sub

セル選択

連続処理をする場合Cellsプロパティを使った方が便利だと思います。
Range("AA1") セルの列は、Column数字 Cells(1,25) だけでなく
アルファベット Cells(1, "AA") でも指定できます。

Sub セル選択()

Range("AA1").Select
MsgBox ("Range(""AA1"") を選択しました。")

Cells(2, "AA").Select
MsgBox ("Cells(2, ""AA"") を選択しました。")

Cells(3, 27).Select
MsgBox ("Cells(3, 27) を選択しました。")

MsgBox ("Columns(""AA"").Column -> " & Columns("AA").Column)
End Sub

複数行・列選択

複数の行や列を選択する場合の記述方法はいくつかあります。

Sub 複数行列選択()

'行の記述方法
Range("4:7").Select
MsgBox "Range(""4:7"").Select"

Rows("2:5").Select
MsgBox "Rows(""2:5"").Select"

Range(Rows(6), Rows(8)).Select
MsgBox "Range(Rows(6), Rows(8)).Select"

'列の記述方法
Range("B:E").Select
MsgBox "Range(""B:E"").Select"

Columns("E:G").Select
MsgBox "Columns(""E:G"").Select"

Range(Columns(6), Columns(8)).Select
MsgBox "Range(Columns(6), Columns(8)).Select"

End Sub

式の書き出し

式のある行にカーソルを置いてマクロを実行します。
カーソル行の下に「R1C1形式の式」・「A1形式の式」・「書式」を書き出します。

Sub 式の書き出し()

Dim i
Dim shiki
Dim lastrow
Dim lastcol
Dim rowno

'最終列取得
With ActiveSheet.UsedRange
    lastcol = .Cells(.Count).Column
End With
rowno = ActiveCell.Row 'アクティブセル行取得

For i = 1 To lastcol

    'R1C1形式
    shiki = Cells(rowno, i).FormulaR1C1
    'Function呼出
    Cells(rowno + 1, i) = "Cells(" & rowno & ", " & i & ").Formula = " & shikitext(shiki)

    'A1形式
    shiki = Cells(rowno, i).Formula
    'Function呼出
    Cells(rowno + 2, i) = "Cells(" & rowno & ", " & i & ").Formula = " & shikitext(shiki)

    '書式
    shiki = Cells(rowno, i).NumberFormatLocal
    Cells(rowno + 3, i) = "Cells(" & rowno & ", " & i & ").NumberFormatLocal = " & shikitext(shiki)
Next

MsgBox ("おわり")
End Sub

Function shikitext(charform)
'式の書き出し（Function）「""」の処理
Dim okikae
Dim char
char = charform
okikae = Replace(char, Chr(34), Chr(34) & Chr(34))
shikitext = Chr(34) & okikae & Chr(34)
End Function

数字のみ取得

データ入力で電話番号検索などで局番の区切りが「（　）」や「－」であったり、
局番の区切りが変更になったなど、数字のみで検索する場合などに使用。

Sub 数字のみ取得()

Dim chara
Dim fig

Rem Range("A1").Select
chara = "032131-131313-14856316"

'Function呼出
fig = onlysuji(chara)
MsgBox (chara & Chr(13) & fig)
End Sub

Function onlysuji(data)
'数字のみ取得（Function）
Dim suji, getchr, chk As String
Dim datalen, i, c As Integer
suji = "0123456789"
datalen = Len(data)
For i = 1 To datalen
    getchr = Mid(data, i, 1)
    c = InStr(1, suji, getchr)
    If c <> 0 Then chk = chk & getchr
Next
onlysuji = chk
End Function

Sub 読込BOOK確認

読込BOOK名・Sheet名の確認します。
複数ブックや複数シートに交互にアクセスする、

Sub 読込BOOK確認()

Dim WB As Workbook
Dim SHT As Worksheet
Dim cnt

'ブック名確認
For Each WB In Application.Workbooks
    cnt = 1
    WB.Activate
    MsgBox ("ファイル名は　" & WB.Name)

    'シート名確認
    For Each SHT In Sheets
        Sheets(SHT.Name).Select
        MsgBox ("(For Each) " & cnt & " - " & SHT.Name)
        cnt = cnt + 1
    Next

    'シート名確認２
    For i = 1 To Sheets.Count
        Sheets(i).Select
        MsgBox (i & " - " & Sheets(i).Name)
    Next

Rem If ActiveWorkbook.Sheets(1).Name = "環境設定" Then　***
Rem If ActiveWorkbook.Name = "macro.xls" Then　***

Next
End Sub