フィールドはWord文書にただの文字列とは違う効果を与えるための仕組みで、日付が自動的に更新される仕組みもこのフィールドが使われています。
Wordの索引は、対象となる文字列に索引項目フィールドを追加して作られます。
索引項目は「蜜柑{ XE “蜜柑”\y”みかん”}」のように表示されます。
これを一括して削除するためのマクロです。
Sub 索引項目一括削除()
For Each myfield In ActiveDocument.Fields
If myfield.Type = wdFieldIndexEntry Then
myfield.Delete
End If
Next
End Sub
Word文書には範囲指定した部分に対してコメントを付けることができます。
しかし範囲を変更することができません。
そこでマクロを作ってみました。
使い方
正しい範囲を指定します。
このとき元の範囲と重なる部分が必要です。つまり範囲を広げるか狭めるかのいずれかです。全く別の場所に移動することはできません。
マクロ「コメント範囲変更」を実行します。
元のコメントが削除され、新たに指定した範囲に元のコメント文がセットされます。
VBAコード
Sub コメント範囲変更()
With Selection.Range
rs = .Start
re = .End
End With
For Each mycomment In ActiveDocument.Comments
With mycomment
ss = .Scope.Start
se = .Scope.End
If (rs <= ss And ss <= re) _
Or (rs <= se And se <= re) _
Or (ss <= rs And rs <= se) _
Or (ss <= re And re <= se) Then
myindex = .Index
mytext = .Range.Text
End If
End With
Next
With ActiveDocument
.Comments(myindex).Delete
.Comments.Add Range:=Selection.Range, Text:=mytext
End With
End Sub
Wordのコメントだけを抽出して一覧にするマクロです。
Word文書を開き、マクロ「コメント一覧作成」を実行すると、文書の末尾にコメント一覧を出力します。
Word2007で確認しました。
VBAコード
Sub コメント一覧作成()
With ActiveDocument.Content
.InsertAfter "【コメント一覧】"
.InsertParagraphAfter
For Each mycomment In ActiveDocument.Comments
With mycomment
i = .Index
d = .Date
a = .Author
rt = .Range.Text
st = .Scope.Text
End With
.InsertAfter i & ">" & d & ">" & a & "「" & st & "」" & rt
.InsertParagraphAfter
Next
End With
End Sub
出力例
【コメント一覧】
1>2012/04/02 14:38:00>佐藤「緑茶」ここは紅茶では？
2>2012/04/04 10:38:00>鈴木「コーヒー」具体的な豆の名前が必要。
3>2012/04/03 15:39:00>佐藤「売上」単位は？
文化祭などでチケットを手作りすることはよくあると思います。
これをExcelで作り、1枚ずつ通し番号を付けたいとします。
A4の紙を使うとして紙1枚からチケット4枚を印刷することにします。
Excel2007で確認しましたが別のバージョンでも動くと思います。
Excelでチケットを作る
- Excelで1枚分のチケットを作ります。
- 通し番号をセットするセルを決めます。ここでは「C2」とします。
- 1枚分の範囲を3回コピーしてA4版に4枚分のチケットを作ります。
- 2枚目の通し番号のセルに「=C2+1」と入力します。
- 3枚目の通し番号のセルに「=C2+2」と入力します。
- 4枚目の通し番号のセルに「=C2+3」と入力します。
マクロを設定する
Visual Basic Editorを開き、次のマクロをセットします。
Sub 連続印刷()
myrow = 2 'セットするセルの行(C2ならば「2」)
mycol = 3 'セットするセルの列(C2ならば「3」)
numberfrom = 1 '最初の番号
numberto = 1000 '最後の番号
numberstep = 4 '1ページあたりの番号
For i = numberfrom To numberto Step numberstep
Cells(myrow, mycol) = i
Sheets.PrintOut
Next i
End Sub
状況に応じて書き換えます。
myrowとmycolは通し番号をセットするセルの行と列です。「C2」ならば、myrowに「2」、mycolに「3」とします。
numberfromは最初の番号です。
numbertoは最後の番号です。チケットを1000枚作るならば「1000」とします。
numberstepは1ページあたりのチケットの枚数です。
マクロを実行する
このマクロを実行します。
通し番号を順々にセットして連続して印刷します。
半角英数字では半角スペースが単語を区切るので、ないと困りますが、日本語間の半角スペースは不要である場合があります。
日本語(半角英数字以外)動詞に挟まれた半角スペースだけを削除するExcelのマクロを考えてみました。
Like演算子を使っています。
3文字ずつチェックし、「日本語」「半角スペース」「日本語」と並んでいる場合、「半角スペース」を取り除き、「日本語」「日本語」とします。
「Like “[!0-9a-zA-Z]“」とすることで、半角数字と半角英字以外を調べることができます。
Sub 選択範囲の全角文字間のスペースを削除する()
Const an = "[!0-9a-zA-Z]"
Dim c As Object
Dim s, a As String
Dim i As Long
For Each c In Selection
v = c.Value
s = ""
For i = 1 To Len(v)
a = Mid(v, i, 3)
If a Like an & " " & an Then
i = i + 1
End If
s = s + Left(a, 1)
Next i
c.Value = s
Next c
End Sub
複数のExcelファイルに同じパスワードがセットされている場合に、それを一括して解除して保存するマクロです。
逆に一括してパスワードをセットすることもできます。
最初にダイアログでパターンを訊かれますので、解除ならば「はい」、セットならば「いいえ」を選択します。
次にダイアログでパスワードをセットします。
最後にファイルが保存されているフォルダを指定します。下位階層には対応していません。
「”\*.xls”」の部分を適宜、変更してください。
Excel2007で確認しました。
Sub 複数ファイルパスワード操作()
Dim myfolder, myfn, myword, pwopen, pwclose
Dim pattern
'操作を選択
pattern = MsgBox("パスワード解除ならば「はい」、セットならば「いいえ」", vbYesNo)
If pattern = vbCancel Then
Exit Sub
End If
'パスワードをセット
myword = InputBox("パスワードを入力。")
If pattern = vbYes Then
pwopen = myword
pwclose = ""
ElseIf pattern = vbNo Then
pwopen = ""
pwclose = myword
End If
'フォルダを選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "解除したいファイルのあるフォルダを選択"
.AllowMultiSelect = False
If .Show = -1 Then
myfolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
'ファイルを操作
myfn = Dir(myfolder & "\*.xls", vbNormal)
Do Until myfn = ""
Call ファイル開閉(myfn, pwopen, pwclose)
myfn = Dir
Loop
End Sub
Function ファイル開閉(myfn, pwopen, pwclose)
Workbooks.Open Filename:=myfn, Password:=pwopen
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=myfn, Password:=pwclose, WriteResPassword:=""
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Function
ExcelのVBAで半角を全角に変換するのはとても簡単です。
「StrConv」を使うといろいろな変換ができます。
引数に「vbWide」を指定すると半角を全角に変換します。
使用例は次の通りです。
Function han2zen(t)
han2zen = StrConv(t, vbWide)
End Function
次は半角カタカナを全角に変換する方法です。
カタカナは全角に変換するが、英数字は半角のままにしたい、というようなケースに使います。
Function han2zen_kana(t)
Dim u, v As String
Dim i As Long
u = StrConv(t, vbWide)
For i = 1 To Len(u)
If Mid(u, i, 1) Like "[!ァ-ヶー]" Then
v = v & StrConv(Mid(u, i, 1), vbNarrow)
Else
v = v & Mid(u, i, 1)
End If
Next i
han2zen_kana = v
End Function
「Like」を使っています。
これはVBAでワイルドカードを使う場合に用いられます。
You Look Too Cool » VBAでワイルドカードを使う
「Like “[!ァ-ヶー]“」とすることで全角カタカナ以外の場合のみを取り出すことができます。
上の例では全角カタカナ以外の場合のみ半角に変換しています。
VBAでは「Like」を使ってワイルドカード的な使い方ができます。
If myword Like "[a-z]" Then
使い方は次の通りです。
【構文】
文字列がパターンに合致するとTrueを返します。
【パターン】
| 文字パターン |
引数stringの中の一致する文字 |
| ? |
任意の1文字 |
| * |
任意の数の文字 |
| # |
任意の1文字の数字(0-9) |
| [charlist] |
文字リストcharlistに指定した文字の中の任意の1文字 |
| [!charlist] |
文字リストcharlistに指定した文字以外の任意の1文字 |
次にパターンに文字リストを使う場合の例を示します。
半角カタカナ
半角カタカナはコード順で「ｦｧｨｩ…ﾚﾛﾜﾝ」と並ぶので「[ｦ-ﾝ]」とします。
全角カタカナ
全角カタカナはコード順で「ァアィイ…ンヴヵヶ」と並ぶので「[ァ-ヶ]」とします。
ただし長音が含まれないので、これを含めるため「[ァ-ヶー]」とします。
全角ひらがな
全角ひらがなはコード順で「ぁあぃい…ゐゑをん」と並ぶので「[ぁ-ん]」とします。
ただし長音が含まれないので、これを含めるため「[ぁ-んー]」とします。
半角英小文字
半角英大文字
半角数字
「[0-9]」としてもよいのですが半角数字に関しては上述の通り「#」という記号が用意されています。
段組みを使ったWord文書を段組みの情報を残したままテキストで出力する方法です。
1段の場合は40文字、2段の場合は19文字で改行を挿入します。
段組みの段数は「段落.PageSetup.TextColumns.Count」で取得できます。
またセクション区切りの部分(文字コードが12)はそのまま出力すると表示がおかしくなるので判定して無視します。
関数「cut」は文字列に指定した文字数で改行を挿入します。
Sub 段組みをテキスト出力()
'段数に応じて改行を追加しテキストファイルに出力する。
Const mojisu1 = 40 '段数が1のとき
Const mojisu2 = 19 '段数が2のとき
Const myfilename = "d:\test.txt"
Dim danrakusu, dansu, mojisu, i
Dim danraku
Dim mytext
'各段落の文字列と段数を取得し、段数に応じて改行を追加する。
danrakusu = ActiveDocument.Paragraphs.Count
mytext = ""
For i = 1 To danrakusu
danraku = ActiveDocument.Paragraphs(i)
dansu = danraku.PageSetup.TextColumns.Count
If (Asc(danraku) <> 12) Then
If dansu = 1 Then
mojisu = mojisu1
Else
mojisu = mojisu2
End If
mytext = mytext & cut(danraku, mojisu)
End If
Next i
'文字列をテキストファイルに出力する。
With CreateObject("ADODB.Stream")
.Type = 2
.Charset = "utf-8"
.Open
.WriteText mytext, 1
.SaveToFile myfilename, 2
.Close
End With
End Sub
Function cut(str, num)
Dim i
For i = 1 To Len(str)
cut = cut & Mid(str, i, 1)
If i Mod num = 0 Then
cut = cut & Chr(13)
End If
Next i
End Function
Windowsにはファイルの内容を検索する機能があります。
しかしExcelを検索する場合、どのファイルにあるかは表示されますが、どのシートにあるかは表示されません。
シートが多いと、そのファイルを開いてから、また検索する必要があります。
そこで、ある文字列について、特定のフォルダにある、すべてのExcelファイルのすべてのシートを検索し、どのシートにあるかを表示するマクロを考えました。
検索結果を表示するだけでなく、該当のセルにハイパーリンクを張るようになっています。
Excel2007で確認しました。 続きを読む…
最近のコメント