Excel

入力規則で半角英数字とハイフンのみ許可する
印刷用に行の高さを調整するマクロ
マクロでテキストボックスの一括置換
セルを参照してシート名を含んだ数式を作る関数『INDIRECT』
- メールアドレスのみ抽出する

入力規則で半角英数字とハイフンのみ許可する

・半角英数字とハイフンのみ
・10文字以内
データの入力規則 > ユーザー設定で数式に以下を設定。

=AND(COUNT(INDEX(FIND(MID(B6&REPT(" ",10),ROW($1:$10),1),"0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ-"),))=LEN(B6),LENB(B6)<11)

エラーメッセージのタイトル
半角英数10文字以内でご記入ください。
と本文。
半角英数・ハイフンを使用して10文字以内でご記入ください。

印刷用に行の高さを調整するマクロ

EXCELで印刷するとはみ出して切れてたからキレた - けむけむの　明日から本気出す！

今日は、面倒くさい表をExcelでゴリゴリ作った。できたできた。印刷しちゃえ。ふんふんふーん。ん？んん？んんん？画面で見たら綺麗なのに印刷したら、はみ出して切れてしまって、読めんやないかーい！どないなっとんねん。と、キレちゃった経験...

Option Explicit
 Dim 開始明細行 As Integer
 
Public Sub 印刷で切れるのを頑張ってみる()
 Dim own_sheet As Object
 Dim w_cnt As Long
 Dim x As Long
 ' 行の開始を決めておく
 開始明細行 = 1
 ' 初期値セット
 w_cnt = 1
 
For Each own_sheet In Sheets
 own_sheet.Activate
 ' シートの最終行をセット
 ' 各シートのC列を見てます
 w_cnt = own_sheet.Range("C65536").End(xlUp).Row
 
For x = 開始明細行 To w_cnt
 own_sheet.Rows(x).Select
 If own_sheet.Cells(x, 3) <> "" Then
 Selection.RowHeight = ((Selection.RowHeight / 12) * 1.3) * 12 + 12
 End If
 Next
 Next
 End Sub

マクロでテキストボックスの一括置換

テキストボックス置換マクロ.xlsm

使い方

シート名を「changetable」
シートの「A1」に置換前文字列
シートの「B1」に置換後文字列

AllSheet.replist　⇒全シート対象

Sheet.repilis　⇒指定の1シート対象
Set chg_sheet = Worksheets(“シート名”)
のシート名部分に置換対象のシート名を入れる

全シート対象（AllSheet.replist）

Sub replist()
 Dim list_sheet As Worksheet
 Dim chg_sheet As Worksheet
 Dim cnt As Integer
 Dim srcword As String
 Dim repword As String
 Dim txtbox As Object
 ' 置換する元の文字列(A列)と先の文字列(B列)のリストを作っておいて指定
 Set list_sheet = Worksheets("changetable")
 cnt = list_sheet.Range("a1").CurrentRegion.Rows.Count
 Application.ScreenUpdating = False
 ' すべてのシートに対して処理
 For Each chg_sheet In Worksheets
 ' リストのシートは除外
 If chg_sheet.Name <> list_sheet.Name Then
 ' 処理対象のシートをアクティブにする
 chg_sheet.Select
 ' 置換対象のリスト数だけLoop処理
 For i = 1 To cnt
 srcword = list_sheet.Cells(i, "A").Value
 repword = list_sheet.Cells(i, "B").Value
 ' すべてのテキストボックスに対して置換
 For Each txtbox In ActiveSheet.Shapes
 If txtbox.Type = msoTextBox Then
 txtbox.DrawingObject.Text = _
 Replace(txtbox.DrawingObject.Text, srcword, repword, 1, -1, vbTextCompare)
 End If
 Next
 Next i
 End If
 Next chg_sheet
 Application.ScreenUpdating = True
End Sub

個別シート（Sheet.repilis）

Sub replist()
 Dim list_sheet As Worksheet
 Dim chg_sheet As Worksheet
 Dim cnt As Integer
 Dim srcword As String
 Dim repword As String
 Dim txtbox As Object
 ' 置換する元の文字列(A列)と先の文字列(B列)のリストを作っておいて指定
 Set list_sheet = Worksheets("changetable")
 ' 対象シートを指定する
 Set chg_sheet = Worksheets("シートの名前")
 cnt = list_sheet.Range("a1").CurrentRegion.Rows.Count
 Application.ScreenUpdating = False
 ' 処理対象のシートをアクティブにする
 chg_sheet.Select
 ' 置換対象のリスト数だけLoop処理
 For i = 1 To cnt
 srcword = list_sheet.Cells(i, "A").Value
 repword = list_sheet.Cells(i, "B").Value
 ' すべてのテキストボックスに対して置換
 For Each txtbox In ActiveSheet.Shapes
 If txtbox.Type = msoTextBox Then
 txtbox.DrawingObject.Text = _
 Replace(txtbox.DrawingObject.Text, srcword, repword, 1, -1, vbTextCompare)
 End If
 Next
 Next i
 Application.ScreenUpdating = True
End Sub

シート名一覧を取得するマクロ

シート名の取得（セルと配列に格納）：Excel VBA｜即効テクニック｜Excel VBAを学ぶならmoug

Sub sheet_name_list()
Dim i As Long
Dim mySheetCnt As Long
Dim mySheetName As String
 
mySheetCnt = ThisWorkbook.Sheets.Count
 
For i = 1 To mySheetCnt
mySheetName = Sheets(i).Name
ActiveSheet.Cells(i, 1).Value = mySheetName
Next i
End Sub

セルを参照してシート名を含んだ数式を作る関数『INDIRECT』

シート名をセルで参照したい/INDIRECT関数

HEARTSNET(ハーツネット)のパソコントラブル解決法。起動しない、保存できない、画面がおかしいなど、パソコンのトラブルをキーワードやエラーメッセージから検索できます。

メールアドレスのみ抽出する

VBAでメニューの[挿入]－[標準モジュール]から以下を追加する。

Function PickupADR(文字列 As Variant)
Dim re As Variant
Dim Matches As Object, M As Object
Dim i As Long, buf As Variant
Set re = CreateObject("VBScript.RegExp")
With re
.Pattern = "[a-zA-Z0-9-][w-./?]*@[a-zA-Z0-9][a-zA-Z0-9-.]+.[a-zA-Z]+" 'メールアドレスのパターン
.Global = True
If .test(文字列) Then
Set Matches = .Execute(文字列)
If Matches.Count = 1 Then
PickupADR = Matches(0).Value
ElseIf Matches.Count > 1 Then
ReDim buf(0 To Matches.Count)
For Each M In Matches
buf(i) = M.Value
i = i + 1
Next
PickupADR = buf
End If
End If
End With
End Function

以下の関数でメールアドレスを抽出できる。

=PICKUPADR(A1)