戻る

ExcelVBAメモランダム  

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


このメモランダム(備忘録)は、最近物忘れが多くなった私のために
以前に使ったちょっと便利な処理を集めました。
テキスト書き出し
ブック名シート名
セル色の置換
ハイパーリンクのコピー
ハイパーリンクの削除
ワードアートテキスト収集
システムフォント
ユーザーフォームモードレス
文字列検索
オートフィルタでのコピー
選択範囲のサイズ取得
最終アドレス取得
画面非表示
ステータス表示
パスと区切り
セルのアドレス取得
セル選択
複数行・列選択
式の書き出し
数字のみ取得
読込BOOK確認


 テキスト書き出し
Sub テキスト書き出し()

Kugiri = Application.PathSeparator 'OSの区切り記号

MyPath = ActiveWorkbook.Path 'ファイルのオープンしたパス
If MyPath = "" Then '保存していないとMyPathがカラとなる
    MsgBox ("データ保護のため" & Chr(13) & "データを保存してから実行してください")
End
End If

Filename = MyPath & Kugiri & "Sample.txt" 'ファイル名
Open Filename For Output As #1 '書き出しファイルをオープン
For suji = 1 To 10
    Print #1, Trim(suji)
Next
Close #1 'ファイルをクローズ

MsgBox MyPath & Kugiri & " に" & Chr(13) & "「Sample.txt」を出力しました。"
End Sub

ブック名シート名
Sub ブック名シート名1()

Dim firstOP
Dim i, j
Dim WBK As Workbook
Dim Wsht As Worksheet
    
'マクロ実行のBook名
firstOP = ActiveWorkbook.Name
i = 1

'A列にBook名
'B列以降にSheet名


For Each WBK In Application.Workbooks
    Workbooks(firstOP).Sheets(1).Cells(i, "A") = WBK.Name
    j = 1

    For Each Wsht In Workbooks(i).Sheets
        Workbooks(firstOP).Sheets(1).Cells(i, j + 1) = Workbooks(WBK.Name).Sheets(Wsht.Name).Name
        j = j + 1
    Next
    i = i + 1
Next
Workbooks(firstOP).Activate
End Sub

Sub ブック名シート名2()
Dim firstOP
Dim i, j
firstOP = ActiveWorkbook.Name
i = 1
For i = 1 To Application.Workbooks.count
    Workbooks(firstOP).Sheets(1).Cells(i, "A") = Workbooks(i).Name
    For j = 1 To Workbooks(i).Sheets.count
        Workbooks(firstOP).Sheets(1).Cells(i, j + 1) = Workbooks(i).Sheets(j).Name
    Next
Next
End Sub

セル色の置換
マクロ起動時のセル色を指定の色に置き換える。(「検索と置換」で「書式の検索」を使えば塗りつぶしの置換もできます。)
Sub セル色の置換()
Dim lastrow
Dim lastcol
Dim actrow
Dim actcol
Dim selectcolor

If Selection.Interior.ColorIndex = xlNone Or Selection.Interior.ColorIndex = 2 Then
MsgBox ("塗りつぶしの色を選択")
End
End If

selectcolor = Selection.Interior.ColorIndex  '←マクロ起動時の色(検索対象の)取得

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

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

For actrow = 1 To lastrow
For actcol = 1 To lastcol
Cells(actrow, actcol).Select
If Selection.Interior.ColorIndex = selectcolor Then Selection.Interior.ColorIndex = 37 '←置換後の色の指定
Next actcol
Next actrow
Range("A1").Select
MsgBox ("終わりました。")
End Sub
ハイパーリンクのコピー
ハイパーリンクのアドレスを取得し、コピーする。
Sub ハイパーリンクのコピー()

Dim moji

On Error Resume Next             ' ハイパーリンクのアドレスがないとエラーとなる
moji = Range("A1").Hyperlinks(1).Address    ' "A1"のハイパーリンクのアドレスを取得
ActiveSheet.Hyperlinks.Add Range("A2"), moji    ' 取得したハイパーリンクのアドレスを"A2"に書き込む
On Error GoTo 0
End Sub
ハイパーリンクの削除
ハイパーリンクを全て削除する。
 Sub ハイパーリンクの削除()
Dim rowno
Dim colno
Dim lastrow
Dim lastcol

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

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

On Error Resume Next           'ハイパーリンクのアドレスがないとエラーとなる
For rowno = 1 To lastrow
    For colno = 1 To lastcol
        Cells(rowno, colno).Select
        Selection.Hyperlinks.Delete           'ハイパーリンク
    Next
Next
On Error GoTo 0
End Sub

ワードアートテキスト収集
ワードアートのテキストのみを収集し「文字収集」Sheetに書き込みます。
「文字収集」Sheetがあれば「A列」の前に2列挿入。なければ「文字収集」Sheetを作成する。
Sub ワードアートテキスト抽出()

Dim WAtext
Dim shapecnt, shtcnt, WA
Dim temp
WAtext = ""  'WordArtの初期化

'現在の作業シート名取得
temp = ActiveSheet.Name

'Sheet名チェック
For shtcnt = 1 To Sheets.Count
  '「文字収集」sheetがあれば2列挿入
  If Sheets(shtcnt).Name = "文字収集" Then
    Sheets("文字収集").Select
    Columns("A:B").Select
    Selection.Insert Shift:=xlToRight
    Range("A1").Select
    Exit For
  '「文字収集」sheetがなければ作成
  Else
    If shtcnt = Sheets.Count Then  '最後のSheetが「文字収集」でない
      Sheets.Add
      ActiveSheet.Name = "文字収集"
    End If
  End If
Next

'作業シートに戻る
Sheets(temp).Activate

On Error Resume Next  'エラーのスキップ

WA = 1  '行番号

'全てのShapeをチェック
For shapecnt = 1 To ActiveSheet.Shapes.Count
  'Shapeを選択
  ActiveSheet.Shapes(shapecnt).Select
  'ワードアートのTextを収集
   WAtext = Selection.ShapeRange.TextEffect.Text
  If WAtext <> "" Then
    Sheets("文字収集").Cells(WA, "A") = WAtext
    WA = WA + 1
    WAtext = ""
  End If
Next shapecnt

On Error GoTo 0  'エラースキップ終了

Sheets("文字収集").Select
MsgBox "おわりました"
End Sub

システムフォント
システムにインストールされているフォントの一覧を書き出します。
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

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

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

ユーザーフォームモードレス
規定値ではユーザーフォームを表示中は、エクセルの操作はできません。
引数(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 に付属の PANTONE9種類のデータを追加しました。
Sub 入力フォーム()
    UserForm2.Show False
End Sub

●サンプルダウンロード 【入力フォーム】
Excelで直接入力するよりもフォームから入力する方が見やすいです。
TextboxのプロパティMultilineをTrueにすると複数行入力できます。(改行はShift+Enter)
フォームから入力中でもSheetに移動しセルに直接書き込んだりもできます。

文字列検索
下の例は、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ステートメントを使ってキーコードを入力すれば、オートフィルタで表示されていない行があっても1行ずつカーソルを移動できます。
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)の右8桁を取得し"/"を削除
datechr = Replace(Right(Date, 8), "/", "")

'時刻(time)の左8桁を所得し":"を削除
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

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

Dim WB As Workbook
Dim SHT As Worksheet
Dim cnt,i

'ブック名確認
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

    'シート名確認2
    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