VBA | You Look Too Cool

VBAでカレントディレクトリを変更する方法

stabucky — Fri, 08 Mar 2024 10:26:58 +0000

ファイルを出力するExcelのマクロを実行するとそのファイルがどこに行ったか分からなくなることがあります。
カレントディレクトリに出力されるのですが、そもそもカレントディレクトリがどこなのか分かりません。
ファイルのある場所をカレントディレクトリに変更してしまえば問題ないはずです。

Excel VBAでは、カレントディレクトリを変更するための特定のコマンドが用意されています。
これは、ファイルやディレクトリを操作する際に非常に便利です。
その使用例を示します。

' カレントディレクトリをファイルのある場所に変更
ChDrive Left(ThisWorkbook.Path, 1)
ChDir ThisWorkbook.Path

カレントディレクトリを現在のワークブックのある場所に変更します。

ChDrive コマンドは、ドライブを変更します。
Left(ThisWorkbook.Path, 1) は、ワークブックのパスから最初の文字（つまり、ドライブの文字）を取得します。

ChDir コマンドは、ディレクトリを変更します。
ThisWorkbook.Path は、現在のワークブックのフルパスを返します。

これにより、後続のファイル操作コマンドがワークブックと同じ場所を参照するようになります。

選択範囲の全角半角を変換するマクロ

stabucky — Thu, 23 Feb 2023 09:57:33 +0000

Excelのセルを選択した範囲について英字や数字の全角と半角を相互に変換するマクロを作りました。

Sub 選択範囲の全角半角を変換()
Dim c As Object
res = InputBox("1:英字を全角から半角 2:英字を半角から全角 3:数字を全角から半角 4:数字を半角から全角", "全角半角変換", "1")
If res = "1" Then
For Each c In Selection
c.Value = alphabet_zen2han(c.Value)
Next c
ElseIf res = "2" Then
For Each c In Selection
c.Value = alphabet_han2zen(c.Value)
Next c
ElseIf res = "3" Then
For Each c In Selection
c.Value = number_zen2han(c.Value)
Next c
ElseIf res = "4" Then
For Each c In Selection
c.Value = number_han2zen(c.Value)
Next c
End If
End Sub

Function alphabet_zen2han(moto)
For i = 1 To Len(moto)
If Mid(moto, i, 1) Like "[Ａ-Ｚａ-ｚ]" Then
Mid(moto, i, 1) = StrConv(Mid(moto, i, 1), vbNarrow)
End If
Next i
alphabet_zen2han = moto
End Function

Function alphabet_han2zen(moto)
For i = 1 To Len(moto)
If Mid(moto, i, 1) Like "[A-Za-z]" Then
Mid(moto, i, 1) = StrConv(Mid(moto, i, 1), vbWide)
End If
Next i
alphabet_han2zen = moto
End Function

Function number_zen2han(moto)
For i = 1 To Len(moto)
If Mid(moto, i, 1) Like "[０-９]" Then
Mid(moto, i, 1) = StrConv(Mid(moto, i, 1), vbNarrow)
End If
Next i
number_zen2han = moto
End Function

Function number_han2zen(moto)
For i = 1 To Len(moto)
If Mid(moto, i, 1) Like "[0-9]" Then
Mid(moto, i, 1) = StrConv(Mid(moto, i, 1), vbWide)
End If
Next i
number_han2zen = moto
End Function

文字列の類似度を計算するレーベンシュタイン距離をPython、VBAで実装

stabucky — Sat, 12 Nov 2022 06:39:03 +0000

レーベンシュタイン距離とは
Python
VBA

レーベンシュタイン距離とは

文字列が二つあったとき、これらがどれほど類似しているかを知るための指標の一つがレーベンシュタイン距離です。
厳密に言えば「どれほど相違しているかを示す指標」です。

レーベンシュタイン距離 - Wikipedia

ここにレーベンシュタイン距離を求める方法が擬似コードで示されているのでPythonとVBAで書いてみました。
レーベンシュタイン距離は相違を示す指標なので、二つの文字列の長い方の長さで割り1から減じた数値のほうが使いやすいです。
同じ文字列は1.0になります。
類似度を表す関数をsimirality、レーベンシュタイン距離を求める関数をlevenshteinとしました。

Python

def similarity(str0, str1):
ld = levenshtein(str0, str1)
return 1 - ld / max(len(str0), len(str1))

def levenshtein(str0, str1):
len_str0 = len(str0)
len_str1 = len(str1)
d = [[0 for j in range(len_str1 + 1)] for i in range(len_str0 + 1)]
for i in range(len_str0 + 1):
d[i][0] = i
for j in range(len_str1 + 1):
d[0][j] = j
for i in range(len_str0):
for j in range(len_str1):
cost = 0 if str0[i] == str1[j] else 1
d[i + 1][j + 1] = min(d[i][j + 1] + 1, d[i + 1][j], d[i][j] + cost)
return d[len_str0][len_str1]

VBA

Function similarity(str1, str2)
ld = levenshteinDistance(str1, str2)
If Len(str1) > Len(str2) Then
str_len = Len(str1)
Else
str_len = Len(str2)
End If
similarity = 1 - ld / str_len
End Function

Function levenshteinDistance(str1, str2)
x = Len(str1)
y = Len(str2)
ReDim d(x, y)
For i = 0 To x
d(i, 0) = i
Next i
For j = 0 To y
d(0, j) = j
Next j
For i = 1 To x
For j = 1 To y
If Mid(str1, i, 1) = Mid(str2, j, 1) Then
cost = 0
Else
cost = 1
End If
temp = d(i - 1, j) + 1
If temp > d(i, j - 1) + 1 Then
temp = d(i, j - 1) + 1
End If
If temp > d(i - 1, j - 1) + cost Then
temp = d(i - 1, j - 1) + cost
End If
d(i, j) = temp
Next j
Next i
levenshteinDistance = d(x, y)
End Function

Excelを閉じる前に確認するマクロ

stabucky — Tue, 20 Sep 2022 10:28:07 +0000

以前作りその後使わなくなったマクロがあるのでメモとして残します。

Private Sub Workbook_BeforeClose(Cancel As Boolean)
res = MsgBox("開いたままにするか？（閉じるならば「いいえ」）", vbYesNo)
If res = vbYes Then
Cancel = True '"Cancel = True"ならば閉じない。
End If
End Sub

Wordで色を変えて置換するマクロ

stabucky — Mon, 06 Sep 2021 07:01:41 +0000

Wordは文字列の置換をするときに書式を設定することができるので文字の色を変えることもできます。
これをマクロに応用してみました。

Sub テスト()
Call 色を変えて置換("エディタ", wdColorRed, "エディタ", wdColorBlue)
End Sub

Function 色を変えて置換(moto_text, moto_color, saki_text, saki_color)
Set myrange = ActiveDocument.Range(Start:=0, End:=0)
With myrange.Find
.ClearFormatting
.Font.Color = moto_color
.Replacement.ClearFormatting
.Replacement.Font.Color = saki_color
.Text = moto_text
.Replacement.Text = saki_text
.Execute Replace:=wdReplaceAll
End With
End Function

「テスト」が実行用のコードです。

「色を変えて置換」が置換する部分です。
moto_text, moto_color, saki_text, saki_colorにそれぞれ検索文字列、置換元の色、置換文字列、置換先の色をセットします。

色はwdColorRedなどのVBAの定数で表します。
内容はWdColor 列挙 (Word) | Microsoft Docsにあります。

ハイパーリンクがあるセルに網かけをするマクロ

stabucky — Fri, 05 Feb 2021 02:06:54 +0000

以前、ハイパーリンクの有無を判定するユーザー定義関数を紹介しました。
今回は同じ仕組みを使い、ハイパーリンクがあるセルに網かけをするマクロを作りました。

色は「vbYellow」の所で設定します。
カラー定数 | Microsoft Docs

Sub 選択範囲のハイパーリンクがあるセルに網かけ()
Dim c As Object
For Each c In Selection
If c.Hyperlinks.Count > 0 Then
With c.Interior
.Pattern = xlSolid
.Color = vbYellow
End With
Else
With c.Interior
.Pattern = xlNone
End With
End If
Next c
End Sub

ハイパーリンクの有無を判定するユーザー定義関数

stabucky — Fri, 29 Jan 2021 09:36:07 +0000

Excelでそのセルにハイパーリンクがあるか否かを判定するユーザー定義関数を作りました。
「範囲.Hyperlinks.Count」で指定した範囲内のハイパーリンクの数を取得できます。
これを使っています。

Function ISHYPERLINK(myrange As Range)
If myrange.Hyperlinks.Count > 0 Then
ISHYPERLINK = True
Else
ISHYPERLINK = False
End If
End Function

複数のWord文書に対して文字列リストを元に連続して置換するマクロ

stabucky — Thu, 21 May 2020 22:07:40 +0000

以前、Wordに関する次の二つのマクロを紹介しました。
Wordで文字列リストを元に連続して置換するマクロ
 複数のWord文書に対して文字列置換
今般、「これらを組み合わせたい」という要望をいただきましたので、試してみました。

準備
リスト
コード
下階層対応版

準備

適当なフォルダに文字列置換したいWordファイルを保存します。これを「対象フォルダ」と呼びます。
確認せずに一気に置換して上書き保存しますので、これらのファイルは必ずバックアップを取っておいてください。
利用に関しては自己責任でお願いします。

コード

次のコードを使います。使い方が分からない場合は「マクロを書く方法」を参照してください。
マクロを実行するとフォルダを選ぶダイアログが出ます。「対象フォルダ」を選択してください。
選択するとフォルダ内のファイルが順に開き、リストに従って次々に置換が実行され、上書き保存されます。

Sub 複数文書連続処理_リストを元に置換()
Dim mae(100)
Dim ato(100)

'置換用配列
Set paras = ActiveDocument.Paragraphs
x = 0
For i = 1 To paras.Count
thisline = paras(i).Range.Text
parts = Split(thisline, ";")
If UBound(parts) > 0 Then
mae(x) = parts(0)
ato(x) = Replace(parts(1), Chr(13), "")
x = x + 1
End If
Next i

'フォルダの選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択"
.AllowMultiSelect = False
If .Show = -1 Then
mypath = .SelectedItems(1) & "\"
Else
MsgBox "終了します。"
Exit Sub
End If
End With

'Word文書に対する処理
myfile = Dir(mypath & "*.doc*")
Do While myfile <> ""
Documents.Open FileName:=mypath & myfile
For i = 0 To x - 1
Call 文書全体を置換(mae(i), ato(i))
Next i
ActiveWindow.Close SaveChanges:=wdSaveChanges
myfile = Dir
Loop
End Sub
Function 文書全体を置換(mae, ato)
Set myrange = ActiveDocument.Range(Start:=0, End:=0)
With myrange.Find
.ClearFormatting
.Text = mae
With .Replacement
.ClearFormatting
.Text = ato
End With
.Execute Replace:=wdReplaceAll
End With
End Function

下階層対応版

「下の階層を含めたファイル一覧を作成するマクロ」を参考にして、指定したフォルダの配下のフォルダに対応したバージョンを作りました。
宣言以降、全てのコードを下のとおり、まとめました。全てをコピー＆ペーストするだけで使えます。

Dim all_files(9999, 1) As String
Dim last_index

Sub 複数文書連続処理_リストを元に置換()
Dim mae(100)
Dim ato(100)

'置換用配列
Set paras = ActiveDocument.Paragraphs
x = 0
For i = 1 To paras.Count
thisline = paras(i).Range.Text
parts = Split(thisline, ";")
If UBound(parts) > 0 Then
mae(x) = parts(0)
ato(x) = Replace(parts(1), Chr(13), "")
x = x + 1
End If
Next i

'フォルダの選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択"
.AllowMultiSelect = False
If .Show = -1 Then
mypath = .SelectedItems(1) & "\"
Else
MsgBox "終了します。"
Exit Sub
End If
End With

'全てのファイル名を取得（下階層を含む）
Call get_files(mypath)

'Word文書に対する処理
j = 0
Do
Documents.Open FileName:=all_files(j, 1) & all_files(j, 0)
For i = 0 To x - 1
Call 文書全体を置換(mae(i), ato(i))
Next i
ActiveWindow.Close SaveChanges:=wdSaveChanges
j = j + 1
Loop Until all_files(j, 0) = ""
End Sub
Function 文書全体を置換(mae, ato)
Set myrange = ActiveDocument.Range(Start:=0, End:=0)
With myrange.Find
.ClearFormatting
.Text = mae
With .Replacement
.ClearFormatting
.Text = ato
End With
.Execute Replace:=wdReplaceAll
End With
End Function
Function get_files(my_path)
'Word用
'指定したフォルダにある全てのファイル名(パス付)を取得する。
Dim this_file(999) As String
Dim this_path As String
Dim i As Long
Dim j As Long
this_file(0) = Dir(my_path, vbDirectory)
i = 0
Do
i = i + 1
this_file(i) = Dir
Loop Until this_file(i) = ""
For j = 0 To i - 1
If this_file(j) <> "." And this_file(j) <> ".." Then
If GetAttr(my_path & this_file(j)) = vbDirectory Then
Call get_files(my_path & this_file(j) & "\")
ElseIf InStr(this_file(j), ".doc") > 0 Then
all_files(last_index, 0) = this_file(j)
all_files(last_index, 1) = my_path
last_index = last_index + 1
End If
End If
Next j
End Function

2020年7月18日追記
「下階層のファイルにも対応させたい」という要望をいただきましたので、試してみました。

2022年5月24日追記
Word文書以外が保存されている場合でも対応できるように修正しました。

マクロを書く方法

stabucky — Sat, 09 May 2020 09:29:32 +0000

ExcelでVBAが使えるようになったのは5.0からだと思います。このときVBE(Microsoft Visual Basic for Applications)が使えるようになりました。
最近、365を使ってみましたが、使い勝手が同じでした。
Excelのマクロ(VBA)の良いところは、基本的な部分については古いコードがそのまま使えるところです。

マクロを書く方法は次のとおりです。
ここではExcelの場合を紹介しますが、Wordの場合も同様です。

エクセルを開いた状態でAlt+F11を押します(Altキーを押しながらF11キーを押します)。※ここではファイル名をvba_test.xlsmとします。
エディタ(Microsoft Visual Basic for Applications)が開きます。

左側のVBAProjectを右クリックして、挿入 – 標準モジュールを選択します。

標準モジュールの「Module1」として右側にコードが開きます。
ここにコードを書きます。

XLOOKUPをVBAで再現

stabucky — Wed, 16 Oct 2019 03:38:07 +0000

ExcelにはVLOOKUPという関数があります。これが使えるとExcel初心者は卒業と言える気がします。
「ある列を検索して同じ値がある行の別の列の値を返す」という、言葉にすると非常に分かりにくい関数ですが、使えるようになると非常に便利です。
一方で使いにくい部分もあって、例えば検索列よりも返す値の列が右にある必要があります。また返す値の列は検索列から数えて何番目というのを指定する必要があります。

そういう不満の声があったからか、マイクロソフトはXLOOKUPの提供を発表しました。

XLOOKUP 関数 – Office サポート

検索列と返す値の列をそれぞれ指定できるようです。
また縦と横のどちらにも対応します。
しかし、まだ製品版には搭載されていないようです。
そこでVBAで再現してみました。

Function XLOOKUP(検索値, 検索範囲, 戻り値の配列)
ct_search = 0
For Each value_search In 検索範囲
If 検索値 = value_search Then
Exit For
End If
ct_search = ct_search + 1
Next

ct_return = 0
For Each value_return In 戻り値の配列
If ct_search = ct_return Then
Exit For
End If
ct_return = ct_return + 1
Next
XLOOKUP = value_return
End Function