EXCEL VBA-Sample(2)


エクセルの任意のセル範囲をテキストファイルにエクスポートする
Sub ExportAsText()
'シートの選択範囲をテキストファイルとして保存します
Dim Buf As String, FPath As Variant
' セル範囲が選ばれていなければ何もしない
If TypeName(Selection) <> "Range" Then Exit Sub
Selection.Copy
With CreateObject("htmlfile")
Buf = .ParentWindow.ClipBoardData.GetData("text")
End With
Application.CutCopyMode = False
' 中身がなければ保存しない
If Replace(Replace(Buf, vbCrLf, ""), vbTab, "") = "" Then Exit Sub
FPath = Application.GetSaveAsFilename("Export.txt", _
"テキスト ファイル (*.txt),*.txt", , "保存先の指定", "保存")
' キャンセルされたら保存しない
If TypeName(FPath) = "Boolean" Then Exit Sub
With CreateObject("Scripting.FileSystemObject")
With .CreateTextFile(FPath): .Write Buf: .Close: End With
End With
End Sub
<参考>コマンドを実行すると、保存ダイアログが表示されます。名前の初期値は Export.txt です。


エクセルの任意のセル範囲をMS-WORDにエクスポートする
Sub myMSWORDrite()
'選択範囲をワードへエクスポート
Dim WD As Object, Rng As Object, wDoc As Object, wline
Set Rng = Selection
Set WD = CreateObject("Word.Application")
WD.Visible = True
Set wDoc = WD.documents.Add
For Each wline In Rng
wDoc.Content.InsertAfter wline & vbCrLf
Next
Set WD = Nothing
End Sub
<注>Microsoft WORD がインストールされている必要があります。
<参考>起動したWORDに文書1として表示されます。


ブックの分割(シートを単体のブックとして保存する)
Sub mySheetBOOK()
'ブック内の各シートを、単体のブックとして現在のフォルダに保存します。
'ブック名(ファイルの名前)は、シート名.xls です。
'同名のブックが存在する場合、置き換えるかどうかのメッセージが表示されます。
On Error GoTo ErrorHandler
Dim i As Long, wb As Workbook
With ThisWorkbook
For i = 1 To .Worksheets.Count
If MsgBox(Worksheets(i).Name & " のシートをブック保存しますか?", vbYesNo) = vbYes Then
.Worksheets(i).Copy
Set wb = ActiveWorkbook
wb.SaveAs .Path & "\" & .Worksheets(i).Name & ".xls"
wb.Close False
Set wb = Nothing
End If
Next
End With
MsgBox "シートの選択と保存処理が終了しました。"
Exit Sub
ErrorHandler:
Resume Next
End Sub
<参考>ブックに含まれる全シートが個別保存の対象となります。
<参考>シートに名前を付けていない場合、ファイル名は Sheet1.xls のようになります。
<参考>元のブックには何ら影響を与えません。
<注>Graphシートは単体では保存できません。


列Aにエラー値(#VALUE!)があれば行全体を削除
Sub myDeleteERR()
'A列にエラー値(#VALUE!)があれば行全体を削除します

Const intCriteria As String = "#VALUE!"

With Cells(2, 1).CurrentRegion
On Error GoTo errhandler
.AutoFilter Field:=1, Criteria1:=intCriteria
.Offset(1).Resize(.Rows.Count - 1). _
SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ActiveSheet.AutoFilterMode = False
Exit Sub

errhandler:
ActiveSheet.AutoFilterMode = False
MsgBox intCriteria & " は見つかりませんでした。"
End Sub
<参考>A列にエラー値がなければ、メッセージを表示してコードを終了します。
<参考>エラー値 ERROR.TYPE
#NULL! 指定した 2 つのセル範囲に共通部分がない場合に返されます。
正しくない参照演算子、または正しくないセル参照を使っています。
#DIV/0! 数式で 0 (ゼロ) による除算が行われた場合に返されます。
#VALUE! 引数やオペランドの種類が正しくないときや、数式のオートコレクト機能が数式を訂正できないときに返されます。
#REF! 数式中のセル参照が無効なときに返されます。
#NAME? Excel で認識できない名前が使われた場合に返されます。
#NUM! 数式または関数の数値に問題がある場合に返されます。
#N/A 関数や数式に使用できる値がない場合に返されます。
<参考>昨日までの古い日付データ行を削除
Sub myOLDRowDalete()
'昨日までの古い日付データ行を削除(A1に項目、A2以下に日付の場合)
'
If MsgBox("古い日付データ行を削除します。よろしいですか?", vbYesNo) = vbYes Then
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess
Do Until Cells(2, 1).Value = DateValue(Now())
If Cells(2, 1).Value < DateValue(Now()) Then
Rows("2:2").Delete Shift:=xlUp
End If
Loop
End If
End Sub


空白行(データや数式、コメントが入っていない行)を削除
Sub myDeleteBlankROW()
'空白行(データや数式、コメントが入っていない行)を削除

Application.ScreenUpdating = False
On Error Resume Next

With Cells
.SpecialCells(xlCellTypeConstants).EntireRow.Hidden = True
.SpecialCells(xlCellTypeFormulas).EntireRow.Hidden = True
.SpecialCells(xlCellTypeComments).EntireRow.Hidden = True
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.EntireRow.Hidden = False
End With

Application.ScreenUpdating = True
End Sub
<参考>シートの使用範囲内で、空白行をすべて削除します。
<参考>特定の列 C〜D が空白の場合、その行全体を削除するには
上記コード中の With Cells を With Columns("C:D")  と書き換えます。


昨日までの日付データ行を非表示
Sub 昨日までの日付行を非表示()
'昨日までの日付データ行を非表示にします。
'対象セル範囲はA列のA2〜A20の日付としています。
Application.ScreenUpdating = False
Range("A2").Select
Do Until ActiveCell.Address = Range("A20").Offset(1#).Address

If ActiveCell.Value < DateValue(Now()) Then '昨日までの日付の場合
Selection.EntireRow.Hidden = True '非表示
End If
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
End Sub


Sub 全行を表示()
'すべての行を表示します。
Cells.EntireRow.Hidden = False
End Sub
<注>空白セルは非表示となります。
<参考>対象範囲は自由に設定してください。
<参考>条件は論理式( > , >= , = , < , <= , <>  )で設定出来ます。
<参考>特定の文字を含む行を非表示
Sub 特定文字行を非表示()
'特定文字”あ”を含む行を非表示にします。
'対象範囲をA2〜B10に設定しています。
Dim myTgCell As Range

Set myTgCell = Range("A2:B10").Find(What:="あ", LookIn:=xlValue, LookAt:=xlPart)

If Not myTgCell Is Nothing Then
Do Until myTgCell Is Nothing
myTgCell.EntireRow.Hidden = True
Set myTgCell = Range("A2:B10").FindNext
Loop
End If
End Sub
<参考>対象範囲と特定文字は自由に設定してください。
<参考>Findは[編集(E)]-[検索(F)]で自動登録できます。
<参考>値により行を非表示
Sub 値により行を非表示()
'値が 5〜30 の数値の場合、行を非表示にします。
'対象範囲をA2〜A20に設定しています。
Range("A2").Select '最初のセル

Do Until ActiveCell.Address = Range("A20").Address '最後のセル
If ActiveCell.Value >= 5 And ActiveCell.Value <= 30 Then '値の条件
Selection.EntireRow.Hidden = True
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
<参考>対象範囲と値は自由に設定してください。
<参考>セルの値が数値以外は無視されます。


検索文字が含まれる行をカラー表示
Sub mojiRowCOLOR()
'シート上の文字を検索して行をカラー表示します。
'文字は大文字と小文字を区別します。
Dim lc As Long '最終列
Dim lr As Long '最終行
Dim c As Long '列
Dim r As Long '行
Dim moji As String '指定
lc = Range("A1").SpecialCells(xlLastCell).Column
lr = Range("A1").SpecialCells(xlLastCell).Row
moji = InputBox("検索する文字を入力してください")
If moji = "" Then
Exit Sub
ElseIf MsgBox(moji & " を検索してその行をカラー表示します。", vbYesNo) = vbYes Then
For r = 1 To lr
For c = 1 To lc
If InStr(1, Cells(r, c).Value, moji) > 0 Then
Range(Cells(r, 1), Cells(r, lc)).Interior.ColorIndex = 6 '黄色
Exit For
End If
Next
If InStr(1, Cells(r, c).Value, moji) = 0 Then
Range(Cells(r, 1), Cells(r, lc)).Interior.ColorIndex = xlNone
End If
Next
End If
End Sub
<注>シート上のセルに塗りつぶし色を設定している場合、無色(標準)になります。
<注>コード例では、検索文字の大文字と小文字を区別し、その行を黄色としています。
<注>条件は、指定文字が含まれる行としています。

<参考>条件を指定文字が合致する(等しい)セルの場合とするには、
17行目の If InStr(1, Cells(r, c).Value, moji) > 0 Then を
If Cells(r, c).Value = moji Then と書き換えてください。

<参考>行に指定文字が含まれる場合、その行をクリア(データ抹消)とするには、
18行目の Range(Cells(r, 1), Cells(r, lc)).Interior.ColorIndex = 6 '黄色 を
Range(Cells(r, 1), Cells(r, lc)).ClearContents  と書き換えてください。

<参考>条件付き書式で同様のことを行うことが出来ます。
(例)セル範囲 A1:G20を選択して
[書式]-[条件付き書式]-[数式が] で =OR($A1:$G1="TEST") として、書式を指定します。
この場合、指定文字(TEST)の大文字と小文字は区別されません。
<参考>検索(任意の検索範囲指定、ワイルドカード文字可)
Sub 文字検索()
'検索文字に該当するセルを着色(黄色)して表示します。
'検索範囲をマウスで自由に選択できます。
On Error GoTo Error
Dim myCheck 'Like演算子の結果を返すための変数
Dim myCell As Range 'Rangeのオブジェクト用の変数
Dim myRange As Range 'Rangeのコレクション用の変数
Dim i 'カウンタ
Dim myValue '検索する文字
Dim myAddress '検索該当したセル番地
Set myRange = _
Application.InputBox(Prompt:="検索するセル範囲をマウスで指定してください。", _
Title:="検索範囲の指定", Type:=8)
myValue = InputBox(Prompt:="検索文字列(ワイルドカード指定可)を入力してください。", _
Title:="検索文字の指定")
i = 0
For Each myCell In myRange
myCheck = myCell.Value Like myValue
If myCheck = True Then myCell.Interior.ColorIndex = 6 '黄色
If myCheck = True Then i = i + 1
Next
If i > 0 Then
If MsgBox(myValue & " が " & i & "個 見つかりました。色をリセットしますか?", vbYesNo) = vbYes Then
myRange.Interior.ColorIndex = xlNone '色クリア
End If
Else
MsgBox myValue & " に該当するセルは見つかりません。"
End If
Error:
End Sub
<参考>文字列または数値の検索に使用できるワイルドカード文字
<参考>日付を検索する場合は、型宣言で myValue As Date と指定します。

 * (アスタリスク)は、アスタリスクと同じ位置にある任意の数の文字
 ? (疑問符)は、疑問符と同じ位置にある任意の 1 文字
 ~ (チルダ)は、? や * または ~ の前に入力します。疑問符、アスタリスク、またはチルダ文字
<参考>検索値(A1セル)入力で、A列を検索し自動ジャンプ表示 [Sheet1]
Private Sub Worksheet_Change(ByVal Target As Range)
'検索値(a1)で列A3以下を検索ジャンプ表示します。
Dim myRow As Long, myRange As Range
myRow = Target.Row
If Target.Address = Range("a" & myRow).Address Then
If Target.Value = "" Then Exit Sub
Set myRange = Range("A2:" & Cells(Rows.Count, 1).End(xlUp).Address).Find(Range("a1").Value, lookat:=xlWhole)
If myRange Is Nothing Then
MsgBox "検索値は見つかりません。", vbOKOnly, "検索エラー"
Target.Select
Else
myRange.EntireRow.Select
End If
End If
End Sub
<注>A列の行3以下を検索対象としています。A列に複数レコードが存在する場合、最初に見つかった行を表示します。
<参考>全シートを対象に、文字列を順次検索
Sub myMojiSearch()
'全シートを対象に、指定された文字列を順次検索します。
Dim sh As Worksheet, ADD As String
Dim st, c, q, moji
st = Application.InputBox(prompt:="検索文字を入力してください")
If st = "" Then Exit Sub
Set moji = Nothing
For Each sh In Worksheets
With sh.Cells
Set c = .Find(st, LookIn:=xlValues)
If Not c Is Nothing Then
ADD = c.Address
Set moji = c
Do
sh.Select
c.Select
q = MsgBox(sh.Name & ADD & " に見つかりました。" _
& Chr(10) & moji & " を更に検索しますか?", vbYesNo)
If q = vbNo Then Exit Sub
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> ADD
Set c = Nothing
End If
End With
Next
If moji Is Nothing Then
MsgBox "検索文字が見つかりません。"
Exit Sub
ElseIf c Is Nothing Then
MsgBox moji & " をすべて検索しました。終了します。"
End If
End Sub
<注>コード例では、アルファベットの大文字と小文字の区別はされません。

<参考>検索文字と一致する条件とするには
10行目を Set c = .Find(st, LookIn:=xlValues, MatchCase:=True) と書き換えてください。

<参考>MatchCase
大文字と小文字を区別するには、MatchCase:=True を指定します。既定値は False です。

<参考>MatchByte
半角と全角を区別するには、MatchByte:=True 区別しないは、MatchByte:=False を指定します。
<参考>2つのブック間のデータを検索 [Sheet1]
Sub ブック間データ検索()
'Book1とBook2のシート1 A列 のデータを比較します。
'Book2を開いておく必要があります。
'重複データを赤色フォントで表示します。
Dim r As Integer 'Book1行番号
Dim er As Integer 'Book1最終行番号
Dim fcl As Variant '対象セル
er = Range("A65536").End(xlUp).Row
For r = 2 To er '2行目から検索
Set fcl = Workbooks("Book2").Sheets("Sheet1").Columns("A:A").Find(Cells(r, 1), MatchCase:=True)
If fcl Is Nothing Then '重複しない場合
Cells(r, 1).Font.ColorIndex = 0 '黒色
Else '重複データの場合
Cells(r, 1).Font.ColorIndex = 3 '赤色
End If
Next
MsgBox "データの比較が終了しました。"
End Sub
<注>比較するブックの名前はBook1とBook2としています。
<注>アクティブBook(Book1)のVBA-Sheet1にコードを記述します。
<注>Book1とBook2は開かれている必要があります。
<参考>検索対象を[Book2]のSheet1:A列のデータとしています。
複数列を指定したい場合(例:A〜C列)は10行目のコード部分を "A:C" と置き換えてください。


セル内改行文字列を標準表示に戻す
Sub セル内改行全解除()
'シートのセル内改行 [Alt]+[Enter] を取り除きます。
'列幅と行の高さを最適表示に設定します。
Cells.Replace What:=Chr(10), Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Columns.EntireColumn.AutoFit
Rows.EntireRow.AutoFit
End Sub
<注>シートに設定された全てのセル内改行が取り除かれ、列幅と行の高さを最適表示に修正されます。
<参考>列幅と行の高さを変更したくない場合は、6行目と7行目を削除します。
Sub セル内改行解除()
'選択範囲のセル内改行 [Alt]+[Enter] を標準に戻します。
'列幅と行の高さを最適表示に設定します。
With Selection
.Replace vbLf, ""
.EntireColumn.AutoFit
.Rows.AutoFit
End With
End Sub
<注>標準表示に戻したい範囲を選択してマクロを実行します。

<参考>キー操作で、セル内改行 [Alt]+[Enter] された文字列を元に戻す場合
[セルの書式設定]-[配置] で 「折り返して全体を表示する」 のチェックを解除しても中点 「・」 が残ります。

<参考>Sheet1 のサンプルページに 文字の検索/置換 の方法を掲載しています。
<参考>セル幅で改行して表示
Sub セル幅で改行()
'セルの文字列を列幅で折り返して表示します。
With Selection
.WrapText = True
End With
End Sub
<参考>セル内改行ではなく、セルの幅よりも長い文字列を折り返して表示します。


都道府県、区市郡、それ以降の漢字部分、半角数字とハイフン部分の4つに分割 [Module1]
Function SplitAddress(Src As String) As Variant
With CreateObject("VBScript.RegExp")
.Pattern = "(.+[都道府県])?" & _
"((?:余市|市原|市川|廿日市|四日市|八日市|八日市場|.+)[区市郡])" & _
"(.*[^\d\-])([\d\-]*)"
With .Execute(Src)(0).SubMatches
SplitAddress = Array(.Item(0), .Item(1), .Item(2), .Item(3))
End With
End With
End Function
<手順1>上記ユーザー定義関数を定義します。
<手順2>分割したい住所が シートのA1セルにある場合、横方向に4つのセルを選択して、
ユーザー定義関数 =SplitAddress(A1)  と入力し
[CTRL] + [SHIFT] + [Enter] で、配列数式とします。

<参考>Kansu-Sample でマクロを使わない数式例を紹介しています。
<参考>数字とハイフンを1バイト文字で統一
=ASC(SUBSTITUTE(JIS(A1),"ー","−"))
<参考>数字とハイフンを2バイト文字で統一
=SUBSTITUTE(JIS(A1),"ー","−")


セルのデータを、1字づつ分解して別セルに書き出す
Sub MidMOJI()
'セルの値や文字を、1字づつ右隣セルに書き出します
Dim c As Range
Dim i As Integer

For Each c In Range("A1:A10") 'データの範囲
For i = 1 To Len(c.Value) '文字数分だけ繰り返し
Cells(c.Row, i + 1).Value = Mid(c.Value, i, 1) '1字づつ書き出し
Next i
Next c
End Sub
<参考>n桁目を取り出すシート数式(数値のみ)
=TRIM(LEFT(RIGHT(REPT(" ",20)&TEXT(A1,"0"),n),1))

<参考>文字列の長さ(文字数)を取得(文字,数値)
=LEN(A1)
<参考>n番目の文字を取り出す
=MID(文字列,開始位置,文字数)
<参考>文字列の前後空白を削除
=TRIM(A1)
<注>元データの文字数分右側に空白列が必要です。
<参考>上記コード例はセル範囲(A1〜A10)が対象です。選択範囲を対象とする場合は For Each c In Selection とします。

<参考>ユーザー定義関数で入力文字を反転(Module1)
'セルの値や文字を、ABC→CBAのように反転させます
Function REVERSE(r)
REVERSE = StrReverse(r)
End Function
ユーザー関数 =REVERSE(A1)
<参考>反転させたデータを取得したいセルにユーザー関数を入力します。
<参考>=REVERSE("エクセル") とした場合、セルの値は ルセクエ となります。


オブジェクト(図)の表示/非表示を交互に切り替え
Sub myObjONOFF()
'オブジェクトの表示/非表示を交互に切り替えます

Dim x As Object, y As Object
With Worksheets("sheet1") '対象シートを指定

Set x = .Shapes("obj1") '図(obj1)
x.Visible = Not x.Visible '表示なら非表示

Set y = .Shapes("obj2") '図(obj2)
y.Visible = Not x.Visible 'obj2表示ならobj1非表示

End With
End Sub
<注>上記コード例では、オブジェクトにそれぞれ obj1 , obj2 と名前を付けています。
<参考>全図形の表示・非表示を切り替え
Sub myObjONOFF2()
'シート内の全図形の表示・非表示を切り替えます
Dim x As Object
With Worksheets("sheet1")
For Each x In .Shapes
x.Visible = Not x.Visible
Next
End With
End Sub
<参考>オブジェクトをセル条件で表示、非表示にする(1)
Private Sub Worksheet_Change(ByVal Target As Range)
セル条件により、オブジェクトの表示/非表示を自動設定します
If Target.Address = "$A$1" Then '条件セル
If Target = 1 Then '条件が 1 の場合

ActiveSheet.DrawingObjects.Visible = False '条件一致なら非表示
Else
ActiveSheet.DrawingObjects.Visible = True 'すべて表示
End If
End If
End Sub
<参考>全オブジェクトを表示する
Sub myObjAll()
'アクティブシートの全オブジェクトを表示します
ActiveSheet.DrawingObjects.Visible = True 'すべて表示
End Sub
<参考>オブジェクトをセル条件で表示、非表示にする(2)
Private Sub Worksheet_Change(ByVal Target As Range)
'セル条件により、オブジェクトの表示/非表示を指定します
If Target.Address = "$A$1" Then '条件セル
Select Case (Target)
Case Is = 1
ActiveSheet.DrawingObjects.Visible = False 'クリア
ActiveSheet.Shapes("obj1").Visible = True 'オブジェクト1表示
Case Is = 2
ActiveSheet.DrawingObjects.Visible = False '
ActiveSheet.Shapes("obj2").Visible = True 'オブジェクト2表示
Case Is = 3
ActiveSheet.DrawingObjects.Visible = False '
ActiveSheet.Shapes("obj3").Visible = True 'オブジェクト3表示
Case Is = 0
ActiveSheet.DrawingObjects.Visible = False 'すべて非表示
Case Else
ActiveSheet.DrawingObjects.Visible = True '全オブジェクト表示
End Select
End If
End Sub
<参考>シート上のオブジェクトをすべて削除
ActiveSheet.DrawingObjects.Delete 'オブジェクトをすべて削除

<参考>図の配置
ActiveSheet.Shapes("OBJ1").ZOrder msoBringToFront '最前面に移動
ActiveSheet.Shapes("OBJ2").ZOrder msoSendToBack '最背面に移動

<参考>図の表示非表示
ActiveSheet.Shapes("OBJ3").Visible = False '非表示
ActiveSheet.Shapes("OBJ3").Visible = True '表示

ActiveSheet.ChartObjects(1).Visible = True 'グラフ1表示


条件によりピクチャ(図)を自動表示
Private Sub Worksheet_Change(ByVal Target As Range)
'セル条件により 図1を自動表示

If Range("A1").Value >= 1 Then '値が1以上なら
Sheets("Sheet1").Shapes("pic1").Visible = True '図(pic1)を表示
Else
Sheets("Sheet1").Shapes("pic1").Visible = False '非表示
End If
End Sub
<注>条件はセルA1 、値は 1以上としています。図の名前を pic1 としています。


画像挿入(セルサイズに合わせる)
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'シート上でWクリックし、セルサイズに合わせて画像挿入します
Dim WDT, HGT, CTP, CLF, PWD, PHT
Application.ScreenUpdating = False
WDT = Target.Width
HGT = Target.Height
CTP = Target.Top
CLF = Target.Left
On Error GoTo Fin
Application.Dialogs(xlDialogInsertPicture).Show
With Selection.ShapeRange
.LockAspectRatio = msoTrue
PWD = .Width
PHT = .Height
Select Case PHT / PWD
Case Is >= HGT / WDT
.Height = HGT
.Left = CLF + (WDT - .Width) / 2
Case Else
.Width = WDT
.Top = CTP + (HGT - .Height) / 2
End Select
End With
Fin: On Error GoTo 0
Application.ScreenUpdating = True
End Sub
<参考>画像挿入(画像の幅を半分に縮小)
Sub InsertGazo()
'選択した画像をシートに挿入します
'幅を基準に0.5に縮小します
Dim FilePath As Variant
FilePath = Application.GetOpenFilename(",*.*")
If Not FilePath = False Then
ActiveSheet.Pictures.Insert(FilePath).Select
With Selection
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.ScaleWidth 0.5, msoTrue
.ShapeRange.Left = ActiveCell.Left
.ShapeRange.Top = ActiveCell.Top
End With
End If
End Sub
<参考>画像挿入(画像ファイルを指定)
Sub myPICINSERT()
'シートに指定された画像を挿入します。

Dim strPath, strFile

strPath = Range("A1") '画像フォルダ指定
strFile = Range("A2") 'ファイル名指定
ActiveSheet.Pictures.Delete
Range("A4").Select '画像の左上位置指定
ActiveSheet.Pictures.Insert strPath & "\" & strFile
End Sub
画像ファイル名のリストを作成すれば便利です。
メニューの[データ]-[入力規則]-[設定]-[入力値の種類>リスト]-[元の値] で設定します。


シート上の文字(値)で背景画像を変更
Sub mySHEETPIC(Seru As Object)
'値によりワークシートの背景画像を表示します
Dim moji As String
moji = Seru.Value

Select Case (moji)
Case "a" To "e"
SetBackgroundPicture Filename:="D:\My Jpg\Fav\bg02.jpg"
Case "f" To "j"
SetBackgroundPicture Filename:="D:\My Jpg\Fav\bg07d.jpg"
Case "k" To "o"
SetBackgroundPicture Filename:="D:\My Jpg\Fav\bk01a.jpg"
Case "p" To "w"
SetBackgroundPicture Filename:="D:\My Jpg\Fav\bk11r.jpg"
Case Else
SetBackgroundPicture Filename:=""
End Select
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim moji As String
Dim Seru As Object
'一つだけセルを選択したときの処理
If Target.Count = 1 Then
Set Seru = Cells(Target.Row, Target.Column)
Call mySHEETPIC(Seru)
'複数のセルを選択したときの処理
ElseIf Target.Count > 1 Then
For Each Seru In Selection
Call mySHEETPIC(Seru)
Next Seru
End If
End Sub
<参考>シート上の頭文字が、小文字 a-e、f-j 、k-o 、p-w 、で始まる、としています。

指定する文字(Cace "X")や背景画像(BackgroundPicture Filename)は自由に変更してください。
<参考>どのセルに文字入力されても、その値に応じた背景画像に更新します。
<参考>指定セルの文字で背景画像を変更
Private Sub Worksheet_Change(ByVal Target As Range)
'文字により背景画像を自動変更します
Dim moji As String

moji = Range("A1").Value 'セル指定

Select Case (moji)
Case "a" To "e" '頭文字が a〜e なら
SetBackgroundPicture Filename:="D:\My Jpg\Fav\bg02.jpg" '背景画像指定
Case "f" To "j"
SetBackgroundPicture Filename:="D:\My Jpg\Fav\bg07d.jpg"
Case "k" To "o"
SetBackgroundPicture Filename:="D:\My Jpg\Fav\bk01a.jpg"
Case "p" To "w"
SetBackgroundPicture Filename:="D:\My Jpg\Fav\bk11r.jpg"
Case Else
SetBackgroundPicture Filename:=""
End Select
End Sub
<参考>A1セルの頭文字が、小文字 a-e、f-j 、k-o 、p-w 、で始まる、としています。


クリックされた図を切り換える
Sub myPCT_Click()
'最初に表示用オートシェイプ図形を描き、マクロを登録します
'図をクリックするたび、ランダムに画像(ピクチャ)表示します

Const PPath = "C:\My JPG\" '画像のフォルダ指定

Dim R As Integer, FPath As String
With CreateObject("WScript.Shell")
FPath = .ExpandEnvironmentStrings(PPath)
End With
Randomize
R = Int(6 * Rnd)
Select Case R
Case 0: FPath = FPath & "01a.JPG"
Case 1: FPath = FPath & "02db.JPG"
Case 2: FPath = FPath & "sora004.JPG"
Case 3: FPath = FPath & "sora005.JPG"
Case 4: FPath = FPath & "sora006.JPG"
Case 5: FPath = FPath & "osmiko01.JPG"

End Select
ActiveSheet.Shapes(Application.Caller).Fill.UserPicture FPath
End Sub
<注>パス指定(画像があるフォルダ)は使用環境に合わせて書き換えてください。
' Const PPath = "%userprofile%\My Documents\My Pictures\"


オブジェクトをクリックした時の座標 [Module1]
'オブジェクトをクリックした時の座標を取得(Module1)
Public Type lpPoint
lpX As Long
lpY As Long
End Type
Public Declare Function GetCursorPos Lib "user32" (pPoint As lpPoint) As Boolean

Sub myOBJXY()
Dim wShape As Shape
With ActiveSheet
Set wShape = .Shapes(Application.Caller)
'図の名前と挿入位置座標
Range("a1").Value = wShape.Name & " L=" & wShape.Left & " Top=" & wShape.Top
End With

Dim wPoint As lpPoint
If Not GetCursorPos(wPoint) Then
'クリック座標を表示
Range("a2").Value = "X=" & wPoint.lpX & " Y=" & wPoint.lpY
End If
End Sub






'図の名前と挿入位置座標のみの場合は
←ここから






←End Sub を追加し、この行で終了


プレビューと印刷
Sub WebPagePreviewSamp()
'対象をWebページとして保存した場合のプレビューをブラウザで表示します。
'ファイルはテンポラリフォルダに作成され、Webページとしては保存されません。
ActiveWorkbook.WebPagePreview
End Sub
<参考>ヘッダーにユーザー書式の日付設定 [ThisWorkbook]
Private Sub Workbook_BeforePrint(Cancel As Boolean)
'アクティブシートヘッダー中央に平成日付と時刻を設定します
ActiveSheet.PageSetup.CenterHeader = Format(Now, "ggge年 m月 d日 h:m:ss")
End Sub


<ご参考:表示位置>
[左ヘッダー] LeftHeader
[中ヘッダー] CenterHeader
[右ヘッダー] RightHeader
[左フッター] LeftFooter
[中フッター] CenterFooter
[右フッター] RightFooter

<ご参考:日付形式の例>
"ge.m.d" なら H21.10.25
"yy-mm-dd (ddd)" なら 09-10-25 (Sun)
<参考>任意のヘッダーを設定して印刷プレビュー [Module1]
Sub ヘッダーを設定して印刷プレビュー()
'セルの値をヘッダー(上部中央、左、右)に設定して印刷プレビューします。
'A1セル 任意のタイトル名
'A2セル ファイル名 関数 =CELL("filename")
'A3セル 日付時刻 関数 =NOW()
Sheets("Sheet1").Select
Application.SendKeys "{ENTER}", False
Application.Dialogs(xlDialogPageSetup).Show _
Arg1:="&C&""Arial""& " & Range("A1") & _
"&L&""Arial""& " & Range("A2") & _
"&R&""Arial""& " & Range("A3")
ActiveWindow.SelectedSheets.PrintPreview
End Sub


Sub ヘッダー設定クリア()
'ヘッダー設定をクリアします。
Sheets("Sheet1").Select
Application.SendKeys "{ENTER}", False
Application.Dialogs(xlDialogPageSetup).Show _
Arg1:="&C&""Arial""& " & _
"&L&""Arial""& " & _
"&R&""Arial""& "
End Sub
<注>コード例ではシート1のセルA1、A2、 A3 を指定しています。
<注>ファイル名を設定する関数を用いる場合、新規ブックの場合は一旦保存します。
<参考>A1セルに任意のタイトルを入力します。
<参考>A2セルにファイル名を設定するには 関数 =CELL("filename") を入力します。
<参考>A3セルに日付時刻を設定するには 関数 =NOW() を入力します。
<参考>任意のフッターを設定して印刷プレビュー
Sub フッターを設定して印刷プレビュー()
'セルの値 A1,A2,A3 をフッターに指定して印刷プレビューします。
'アクティブシートが対象です。
Dim myFTC As String, myFTL As String, myFTR As String
myFTC = ActiveSheet.Range("A1").Value '中央のフッター指定セル
myFTL = ActiveSheet.Range("A2").Value '左のフッター指定セル
myFTR = ActiveSheet.Range("A3").Value '右のフッター指定セル
With ActiveSheet.PageSetup
.CenterFooter = myFTC
.LeftFooter = myFTL
.RightFooter = myFTR
End With
ActiveWindow.SelectedSheets.PrintPreview 'プレビュー
ActiveSheet.DisplayAutomaticPageBreaks = False
End Sub
<参考>フッターに指定するセルはご自由に変更してください。
<参考>任意の選択範囲のみ印刷(プレビュー)
Sub 選択範囲PPrev()
'選択範囲のみ印刷(プレビュー)します。
ActiveSheet.PageSetup.PrintArea = Selection.Address
ActiveWindow.SelectedSheets.PrintPreview '印刷プレビュー
End Sub


印刷を実行するには
4行目を  ActiveWindow.SelectedSheets.PrintOut Copies:=1  とします。
<参考>セル条件で印刷範囲を設定する
名前:Print_Area
"参照範囲" に数式を設定します
例えば、A1が1ならA1~A10を印刷、1以外ならB1~B10を印刷範囲とします。
=IF(Sheet1!$A$1=1,Sheet1!$A$1:$A$10,Sheet1!$B$1:$B$10)
<参考>指定時刻に印刷
Sub 指定時刻に印刷()
Application.Wait "09:00:00" '時刻を指定
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub
<注>コード例では印刷を 9:00 に指定しています。
<注>時刻が来るまでエクセルを起動状態にしておく必要があります。


新規シート右端挿入
Sub myNEWSHEETR()
'新規シートを右端に挿入します。

Dim i As Integer
i = Worksheets.Count 'シートの数を数えます
Worksheets.Add after:=Worksheets(i)

End Sub
<参考>シート名を ”統合シート” と付けて挿入したい場合は
Worksheets(i + 1).Name = "統合シート" のコードを End Subの前行に追加します。
<参考>今日の日付名シートを右端挿入
Sub myNEWShTODAY()
'今日の日付名シートを右端に挿入します
Dim flag As Boolean
Dim i As Long
On Error GoTo errhandle
flag = False
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Format(Date, "ge年m月d日")
Do While (flag)
ActiveSheet.Name = Format(Date, "ge年m月d日") & "(" & i & ")"
flag = False
Loop
Exit Sub
errhandle:
i = i + 1
flag = True
If i = 1 Then
Resume Next
Else
Resume
End If
End Sub


全シートの項目値を集計する
Sub mySheetTOTAL()
'全シートの項目ごとの値を総合シートに集計します。
'集計するシート名は ”総合”とします。(A列:項目 B列:集計値)
Dim sh As Worksheet 'ワークシート
Dim fc As Range 'FindCell
Dim lr As Integer '総合シート最終行
Dim r As Integer '行番号
Dim Fx As Long '集計値
Dim code As String '項目
Sheets("総合").Activate
lr = Range("A65536").End(xlUp).Row '最終行番号
For r = 2 To lr 'タイトル行以下の集計開始行
If Cells(r, 1).Value = "" Then '項目空白の場合、値クリア
code = Cells(r, 1).Offset(, 1).Clear
ElseIf Cells(r, 1).Value <> "" Then '総合シートの項目(A列)
code = Cells(r, 1).Value
Fx = 0 '集計の初期値
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "総合" Then '集計対象シート
Set fc = sh.Columns("A:A").Find(code)
If Not (fc Is Nothing) Then '各項目セル合致
'各シートのデータ系列(B,C,D,E,F)と集計値(+和算)を指定
Fx = Fx _
+ fc.Offset(, 1) _
+ fc.Offset(, 2) _
+ fc.Offset(, 3) _
+ fc.Offset(, 4) _
+ fc.Offset(, 5) _
.Value
End If
End If
Next
Cells(r, 2).Value = Fx '総合シートB列に集計値記入
End If
Next r
MsgBox "シートの集計処理を完了しました。"
End Sub
<注>集計するシート名は ”総合” としています。
<注>各シートのA列は項目、データ集計範囲はB〜F列としています。
<注>総合シートのA列に集計する項目とした場合、B列に各項目に対する集計値(合計)となります。

<参考>各シートのB列のみ集計するには
23行目を Fx = Fx + fc.Offset(0, 1).Value と書き換え 24〜29行を削除してください。

<参考>総合シートA1にタイトル、A2以下に集計する項目を記入してください。
<参考>シート名を変更するには、画面下部のシートタブ(Sheet1など)をダブルクリックしてください。
<参考>集計に用いる各シートは、統一されたスタイルを設定すると便利です。
<参考>特定シートのデータを項目別に集計 [Module1]
Sub 項目別データ集計()
'Sheet1のデータをSheet2に[項目][品名]で集計します。
'Sheet1のA1=項目、B1=品名、C1=数量、D1=金額 のフィールドが前提です。
'項目に空白があると、そのデータは集計されません。
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
Dim er As Integer 'データの最終行
Dim sr As Integer '集計記入行番号
Dim r As Integer 'ループカウンター 行番号
Dim s1 As Long '数量集計値
Dim s2 As Long '金額集計値
Dim s3 As Long '項目金額集計値
Dim fs As Integer '1stSW
Dim z1 As String 'ZKey1(項目)
Dim z2 As String 'ZKey2(項目+品名)
Dim z3 As String 'Z品名
Sheets("Sheet1").Activate
er = Range("A2").End(xlDown).Row
sr = 2
'E列に作業用の連番
Range("E1").FormulaR1C1 = "No"
Range("E2").FormulaR1C1 = "1"
Range("E3").FormulaR1C1 = "2"
Range("E2:E3").Select
Selection.AutoFill Destination:=Range("E2:E" & er)
Selection.AutoFill Destination:=Range(Cells(2, 5), Cells(er, 5))
'データ範囲を項目、品名順にソート
Range(Cells(2, 1), Cells(er, 5)).Select
Selection.Sort Key1:=Range("A2"), _
Order1:=xlAscending, Key2:=Range("B2"), _
Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False
Range("A2").Select
'集計作業
Cells(er + 1, 1).Value = "END"
Sheets("Sheet2").Activate
Columns("A:D").Select
Selection.Clear
'項目名を転記(A1、B1、C1、D1)
Sheets("Sheet1").Activate
Range("A1:D1").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Sheet1").Select
Application.CutCopyMode = False
For r = 2 To er + 1
If fs = 0 Then '最初のデータ
fs = 1
z1 = Cells(r, 1).Value: z2 = Cells(r, 1).Value & Cells(r, 2).Value
z3 = Cells(r, 2).Value
s1 = Cells(r, 3).Value: s2 = Cells(r, 4).Value: s3 = s2
Else '第2データ以降
If z1 = Cells(r, 1).Value Then '同一項目
s3 = s3 + Cells(r, 4).Value
If z2 = Cells(r, 1).Value & Cells(r, 2).Value Then '同一項目同品名
s1 = s1 + Cells(r, 3).Value
s2 = s2 + Cells(r, 4).Value
Else '同一項目異品名
With Sheets("Sheet2") 'Sheet2にデータ記入
.Cells(sr, 1).Value = z1
.Cells(sr, 2).Value = z3
.Cells(sr, 3).Value = s1
.Cells(sr, 4).Value = s2
sr = sr + 1
z2 = Cells(r, 1).Value & Cells(r, 2).Value
z3 = Cells(r, 2).Value
s1 = Cells(r, 3).Value
s2 = Cells(r, 4).Value
End With
End If
Else '他項目
With Sheets("Sheet2") '品名の転記
.Cells(sr, 1).Value = z1
.Cells(sr, 2).Value = z3
.Cells(sr, 3).Value = s1
.Cells(sr, 4).Value = s2
sr = sr + 1
z2 = Cells(r, 1).Value & Cells(r, 2).Value
z3 = Cells(r, 2).Value
s1 = Cells(r, 3).Value
s2 = Cells(r, 4).Value
.Cells(sr, 1).Value = z1 & ":計" '項目計の転記
.Cells(sr, 4).Value = s3
z1 = Cells(r, 1).Value
s3 = Cells(r, 4).Value
sr = sr + 1
End With
End If
End If
Next
Cells(er + 1, 1).ClearContents
Range(Cells(2, 1), Cells(er, 5)).Select 'データ範囲を復元
Selection.Sort Key1:=Range("E2"), _
Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False
Columns("E:E").ClearContents '作業列Eを削除
Range("A1").Select
MsgBox "項目別集計を終了しました。"
Sheets("Sheet2").Activate
ErrorHandler:
Resume Next
Application.ScreenUpdating = True
End Sub
<注>新規ブックのシート1に元データをコピーし、そのデータに対して集計してください。
<注>集計元シート名は Sheet1、集計先シート名は Sheet2 としています。
<注>集計元シートの1行目には、任意の項目名が必要です。C〜D列のデータは数値が前提です。
<参考>コード例は、ピボットテーブルを用いないでデータ集計を実現します。


複数行列のデータを新規シートに一列コピー
Sub RCChange()
'シート1複数行列の内容を、新規シートのA列に書き出します
Dim wRend, i, J, K
Dim s As Integer
Dim wSht As Worksheet
s = Worksheets.Count
Worksheets.Add after:=Worksheets(s) '新規シート
Set wSht = ActiveSheet
With Worksheets("Sheet1")
wRend = .Range("a65536").End(xlUp).Row
K = 0
For i = 1 To wRend
For J = 1 To .Cells(i, 256).End(xlToLeft).Column
K = K + 1
wSht.Cells(K, 1) = .Cells(i, J)
Next
Next
End With
End Sub
<参考>選択範囲を新規シートに行列入れ替えコピー
Sub CLOSSCOPY()
' 選択範囲を新規シートに行列を入れ替えてコピーします。

Dim i As Integer
i = Worksheets.Count 'シートの数を数えます
Selection.Copy '選択範囲をコピー
Worksheets.Add after:=Worksheets(i) '新規シートを右端に挿入します

Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True '行列を入れ替えて値のみ貼り付けます
End Sub
<参考>複数行列を関数式で別の一列(G1)に取り出す例
=OFFSET($A$1,(ROW(G1)-ROW(G$1))/5,MOD(ROW(G1)-ROW(G$1),5))


指定の方法でコピー
Sub myCOPY1()
'セルの値を全てコピー
'Range("A1").Copy Destination:=Range("B1") 'A1をB1に全てコピー
Application.CutCopyMode = False
End Sub
Sub myCOPY2()
'値のみコピー
Range("A1").Copy
Range("B1").PasteSpecial Paste:=xlValues 'A1をB1に値のみコピー
Application.CutCopyMode = False
End Sub
Sub myCOPY3()
'加算してコピー
'Range("A1").Copy
'Range("B1").PasteSpecial Paste:=xlValues, Operation:=xlAdd 'A1の値をB1に加算してコピー
Application.CutCopyMode = False
End Sub


アクティブ行をカラー表示する
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'カーソルのある行を着色表示します。
Cells.Interior.ColorIndex = xlNone
ActiveCell.EntireRow.Interior.ColorIndex =
6 '行全体を黄色
End Sub
<注>シート上の特定セルやセル範囲に色を設定している場合、すべて塗りつぶしなしとなります。
<参考>コード中の 6 はエクセルの標準カラーパレットインデックス(色番号)指定です。

カラーパレットインデックス(ColorIndex)

1 濃い黄 12 ベージュ 40
2 25%灰色 15 薄い青 41
3 50%灰色 16 アクア 42
明るい緑 4 スカイブルー 33 ライム 43
5 薄い水色 34 ゴールド 44
6 薄い緑 35 薄いオレンジ 45
ピンク 7 薄い黄 36 オレンジ 46
水色 8 ペールブルー 37 ブルーグレー 47
濃い赤 9 ローズ 38 40%灰色 48
10 ラベンダー 39 53
* 色は画面と実際とは違って見えますので、あくまで参考です。

<参考>カーソルがある行の最初の列をカラー表示
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'カーソルのある行のA列のみカラー表示します。
'A列が非表示の場合、カラーも非表示となります。
Columns(
1).Interior.ColorIndex = xlNone
Cells(Target.Row,
1).Interior.ColorIndex = 6 '1列目(A列)を黄色
End Sub
<参考>コード中の 1 が左から1列目(A列)を指定しています。2ならB列となります。


カーソル移動制御
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
'G列より右を選択した場合、A列データの次の行にフォーカスを移動します。
'データベース入力(1行1レコード)に最適です。
Dim myColumnNO As Long
myColumnNO = ActiveSheet.Range("A1").End(xlToRight).Column
If Target.Column > 6 Then 'G列以降にフォーカス移動の時
入力開始位置
ElseIf Target.Column > myColumnNO Then
Target.Offset(1, -Target.Column + 1).Select
If ActiveCell.Value <> Empty Then 入力開始位置
End If
End Sub
Sub 入力開始位置()
Application.MoveAfterReturnDirection = xlToRight '入力後右方向へ移動
Dim myRowNO As Long
myRowNO = ActiveSheet.Rows.Count
Cells(myRowNO, 1).End(xlUp).Offset(1, 0).Select '次の行
End Sub
<参考>コード6行目の >6 が左から数えて何番目の列以降かを指定しています。
<注>Excel標準設定では、[Enter]キーでセル移動方向は下となっていますがコード実行後は右になります。
セルに入力後、下方向へ移動したい場合は、14行目を削除してください。
[ツール]-[オプション]-[編集]-[入力後にセルを移動する]-[方向]で変更可能です。
<参考>入力する列を限定する
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'選択行の左端(n番目列のみ)にカーソル移動
Cells(Selection.Row, 1).Select '制限する列を指定
End Sub
<参考>シート上のどのセルをクリックしても、その行の左端セルにカーソルが移動します。
入力セルを制限したい場合に有効です。
<参考>コード例では最左列(左から数えて1番目)を指定しています。
<参考>フォーカスをA列へ移動させる
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 7 Then
Target.Offset(0, -6).Select
End If
End Sub
<参考>コード例では、G列(7列目)を選択した場合のみ、同じ行のA列にカーソルが移動します。
コード例3行目の Offset(0, )なら同じ行、1なら次の行のA列へ移動します。
コード例3行目の Offset(0, -6)は戻る列数を指定しています。
<参考>保護セルにカーソル移動を禁止するには
Private Sub Worksheet_Activate()
'シートを自動的に保護します
'カーソル移動を制限(非保護セルのみ)します

ActiveSheet.Protect
Dim sh As Object
For Each sh In Worksheets
sh.EnableSelection = xlUnlockedCells
Next
ActiveCell.Next.Select
End Sub


<注>入力可能セルの設定は、一旦シート保護を解除して行います。
手順は、セル範囲選択→右クリック→[セルの書式設定]→[保護]→[ロック]のチェックをはずします。
その後、シート保護を設定してください。
<参考>ブックを開く時に、保護を実行するには[ThisWorkbook]
Private Sub Workbook_Open()
'ブック保護(シート構成)
ActiveWorkbook.Protect Structure:=True, Windows:=False
'ブック保護(シート構成とウインドウ)
ActiveWorkbook.Protect Structure:=True, Windows:=True
End Sub
<参考>セルの移動方向をブックに設定 [ThisWorkbook]
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'BOOKを閉じる時、[ENTER]キー押下後の移動方向を標準(下)にします。
Application.MoveAfterReturnDirection = xlDown
End Sub

Private Sub Workbook_Open()
'BOOKを開く時、[ENTER]キー押下後の移動方向を(右)にします。
Application.MoveAfterReturnDirection = xlToRight
End Sub
<参考>シート単位で指定する場合、例えば シート1のみ制御するにはVBA [Sheet1] に下記コードを記述してください。
Private Sub Worksheet_Activate()
'シートがアクティブ(選択されている状態)の時、右へ移動
Application.MoveAfterReturnDirection = xlToRight
End Sub

Private Sub Worksheet_Deactivate()
'シートが非アクティブ(未選択)の時、他のシートでは下へ移動
Application.MoveAfterReturnDirection = xlDown
End Sub


空白セルのみユーザー入力を許可
Sub mySheetLock()
'シート使用範囲内で、空白セルのみユーザー入力を許可します
'シート保護解除にはパスワード(abc)が必要となります

ActiveSheet.Unprotect password:="abc" 'シート保護解除パスワード設定

Cells.Locked = True
ActiveSheet.UsedRange.SpecialCells _
(Type:=xlCellTypeBlanks).Locked = False

ActiveSheet.Protect password:="abc" 'パスワード

End Sub
<参考>シート保護解除パスワードを abc と設定しています。任意に変更してください。


データ登録を自動実行 [Sheet1]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'G2セルにフォーカス移動でデータ登録を実行します。
If Target.Address = Range("G2").Address Then
Call データ入力
Range("A2:F2").ClearContents '登録済データエリアをクリア
Range("A2").Select
End If
End Sub

Sub データ入力()
'データ入力セルを A2〜F2 としています。
'データベース範囲の先頭をA5セルとしています。
'セルG2にフォーカス移動で、自動的にデータを書き込みます。
On Error GoTo ErrorHandler
Dim myCount As Long
Sheets("Sheet1").Select 'データシート
myCount = Range("A5").CurrentRegion.Rows.Count 'データ項目
Cells(4 + myCount, 1).Select 'データ
ActiveCell.Offset.Range("A2:F2").Value = _
Array(Range("A2").Value, _
Range("B2").Value, _
Range("C2").Value, _
Range("D2").Value, _
Range("E2").Value, _
Range("F2").Value)
ErrorHandler:
Resume Next
End Sub
<注>データ入力用セルをシート1のA2〜F2 としています。G2セルにフォーカスが移動するとデータが登録されます。
<注>登録するデータベース範囲の先頭をA5セルとしています。
<注>任意のデータ項目名をA5〜F5に必ず記入してください。
<参考>一行目(A1〜F1)は入力データ用の項目名とするとわかりやすくなります。
<参考>入力された項目が一つだけでも、1件のデータとして登録されます。
<参考>データ入力用(A2〜F2)のセル書式がそのまま適用されます。
<参考>データ登録(登録番号付き、必須入力あり)を自動実行 [Sheet1]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'G2セルにフォーカス移動でデータ登録を実行します。
If Target.Address = Range("G2").Address Then
Call データ入力2
Range("A2:F2").ClearContents '登録済データエリアをクリア
Range("A2").Select
End If
End Sub

Sub データ入力2()
'データ入力セルを A2〜F2 としています。
'必須入力を A2 セルとしています。
'データベース範囲の先頭をA5セルとしています。
'セルG2にフォーカス移動で、自動的にデータを書き込みます。
On Error GoTo ErrorHandler
Dim myCount As Long
Sheets("Sheet1").Select 'データシート
myCount = Range("A5").CurrentRegion.Rows.Count 'データ件数
If Range("A2") = "" Then Exit Sub 'A2セルが未入力の場合は登録中止
Cells(4 + myCount, 2).Select 'データ
ActiveCell.Offset(1, -1) = myCount '登録データ番号
ActiveCell.Range("A2:F2").Value = _
Array(Range("A2").Value, _
Range("B2").Value, _
Range("C2").Value, _
Range("D2").Value, _
Range("E2").Value, _
Range("F2").Value)
ErrorHandler:
Resume Next
End Sub
<注>データ入力用セルをシート1のA2〜F2 としています。G2セルにフォーカスが移動するとデータが登録されます。
<注>任意のデータ項目名をA5〜G5に必ず記入してください。
<注>A2セルが未入力の場合は登録されません。
<参考>データ入力用セルに、例えば [入力規則]-[リスト] を設定するとデータ登録作業が容易です。


プログラムの進行状況を確認するプログレスバーを作成する
概要
UserForm を使用してマクロが正常に進行していることを示す Progress ber (進行状況を確認するバー) を表示することができます

詳細
進行状況を示す Progress ber を表示するには

1. 新規のワークブックを開きます既に開いているワークブックがある場合は閉じます
[ファイル] をクリックし、[新規作成] をクリックします次に、[標準] タブをクリックし、[ブック] をクリックして、[OK] をクリックします

2. Visual Basic Editor を起動します
[ツール] をクリックし、[マクロ] をポイントします次に、[Visual Basic Editor] をクリックします

3. [プロパティ] ウィンドウを開きます既に開いている場合は、手順 4. へ進みます
[表示] をクリックし、[プロパティ ウィンドウ] をクリックします

4. [UserFoam] を開きます
[挿入] をクリックし、[ユーザー フォーム] をクリックします

5. ラベルを作成します
[ツールボックス] の [ラベル] をクリックし、[UserForm1] でドラッグ アンド ドロップしてラベルを作成します

6. ラベルの文字を書き換えます
"Label1" と表示されている場所に「アップデート中ですしばらくお待ちください・・・」(「」は除く) と入力します

7. フレームを作成します
[ツールボックス] の [フレーム] をクリックし、[UserForm1] でドラッグ アンド ドロップしてフレームを作成します

8. [Frame1] のプロパティを変更します
[プロパティ] ウィンドウの [全体] タブをクリックし、[オブジェクト名] ボックスに「FrameProgress」(「」は除く) と入力します

9. ラベルを作成します
[ツールボックス] の [ラベル] をクリックし、[Frame1] 上でドラッグ アンド ドロップしてラベルを作成します

10. ラベルの文字を削除します

11. [Label2] のプロパティを変更します
[プロパティ] ウィンドウの [全体] タブをクリックします次に、[オブジェクト名] ボックスに「LabelProgress」(「」は除く)、[BackColor] ボックスに「&H000000FF&」(「」は除く) とそれぞれ入力し、[SpecialEffect] ボックスの一覧から「fmSpecialEffectRaised」をクリックします

12. サイズを調整します
[UserForm1] の大きさ、ラベルやフレームの位置をマウスで調整します

13. [UserForm1] の [コード] ウィンドウを開きます
UserForm をダブルクリックし、[コード] ウィンドウを開きます

14. [UserForm] および [Activate] を選択します
[オブジェクト] ボックスの一覧から [UserForm] をクリックし、[プロシージャ] ボックスの一覧から [Activate] をクリックします

15. 不要な行を削除します
Private Sub UserForm_Activate()
End Sub


16. UserForm Activate イベントのコードを入力します
Private Sub UserForm_Activate()
' Set the width of the progress bar to 0.
UserForm1.LabelProgress.Width = 0
' Call the main subroutine
Call Main
End Sub



17. [標準モジュール] を開きます
[挿入] をクリックし、[標準モジュール] をクリックします


18. [Module1] にコードを入力します
Sub ShowUserForm()
UserForm1.Show
End Sub
Sub Main()
Dim Counter As Integer
Dim RowMax As Integer, ColMax As Integer
Dim r As Integer, c As Integer
Dim PctDone As Single
Application.ScreenUpdating = False
' Initialize variables.
Counter = 1
RowMax = 100
ColMax = 25
'Loop through cells.
For r = 1 To ColMax
For c = 1 To ColMax
'Put a random number in a cell
Cells(r, c) = Int(Rnd * 1000)
Counter = Counter + 1
Next c
'Update the percentage completed
PctDone = Counter / (RowMax * ColMax)
'Call subroutine that updates the progress bar.
UpdateProgressBar PctDone
Next r
'The task is finished, so unload the UserForm.
Unload UserForm1
End Sub
Sub UpdateProgressBar(PctDone As Single)
With UserForm1
'Update the Caption Property of the Frame control.
.FrameProgress.Caption = Format(PctDone, "0%")
'widen the Label control.
.LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
End With
'The DoEvents allows the UserForm to update
DoEvents
End Sub



19. Excel  を表示します
[表示] をクリックし、[Microsoft Excel] をクリックします

20. [マクロ] を起動します
[ツール] をクリックし、[マクロ] をポイントします次に、[マクロ] をクリックします

21. マクロを実行します
[マクロ名] ボックスの一覧から [ShowUserForm] をクリックし、[実行] をクリックします

22. 作成したダイアログ ボックスが表示されます


256列を超える CSV ファイルを読み込む
Option Explicit
Dim nRow As Long, oBuf As Variant, RegEx As Object
Sub OpenWideCSV()
Dim I As Long, L As Long, FPath As Variant, iBuf As Variant
FPath = Application.GetOpenFilename( _
"CSV ファイル(*.csv),*.csv", , "ファイルの選択")
If TypeName(FPath) = "Boolean" Then Exit Sub
With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile(FPath)
iBuf = Split(.ReadAll, vbCrLf): .Close
End With
End With
nRow = UBound(iBuf)
Do While iBuf(nRow) = "": nRow = nRow - 1: Loop
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Global = True: RegEx.Pattern = """": Workbooks.Add 1
For I = 0 To nRow
ReplaceC2T iBuf(I)
Application.StatusBar = "前処理中 : " & I + 1 & "/" & nRow + 1
Next I
Application.StatusBar = ""
ReDim oBuf(nRow): RegEx.Pattern = "^(?:[^\t]*\t){256}"
Do While RegEx.Test(iBuf(0))
For I = 0 To nRow
L = RegEx.Execute(iBuf(I))(0).Length
oBuf(I) = Left(iBuf(I), L - 1): iBuf(I) = Mid(iBuf(I), L + 1)
Next I
Call ReadSheet: If iBuf(0) = "" Then Exit Sub
ActiveWorkbook.Sheets.Add , ActiveSheet
Loop
oBuf = iBuf: Call ReadSheet
End Sub
'
Private Sub ReadSheet()
Dim nCol As Long, I As Long, J As Long
Dim aBuf As Variant, RBuf As Variant
nCol = UBound(Split(oBuf(0), vbTab)): ReDim aBuf(nRow, nCol)
For I = 0 To nRow
RBuf = Split(oBuf(I), vbTab)
For J = 0 To nCol
If Left(RBuf(J), 1) = """" Then _
RBuf(J) = Mid(RBuf(J), 2, Len(RBuf(J)) - 2)
aBuf(I, J) = Replace(RBuf(J), """""", """")
Next J
Next I
Range("A1").Resize(nRow + 1, nCol + 1) = aBuf
End Sub
'
Private Sub ReplaceC2T(Src As Variant)
Dim Buf As Variant, aBuf As String, Tmp As String
Dim I As Long, J As Long
Buf = Split(Src, ",")
For I = 0 To UBound(Buf)
aBuf = Tmp & Buf(I): Tmp = aBuf & ","
If RegEx.Execute(aBuf).Count Mod 2 = 0 Then _
Buf(J) = aBuf: J = J + 1: Tmp = ""
Next I
ReDim Preserve Buf(J - 1): Src = Join(Buf, vbTab)
End Sub
<参考>256列を超える、他のアプリケーションから出力された CSV ファイルを
複数のシートに読み込む VBA コード例です。
<注>各項目データの中にはカンマが含まれないこと、各行の項目数が同一であること、が対象ファイルの前提条件です。

<参考>正規表現表記(パターン) RegEx.Pattern = "^(?:[^\t]*\t){256}"
1シートに読み込めるタブ区切り列データの1行分を意味します。
?: はサブマッチを記憶しないでメモリを節約する目的で記述していますが、
速度やメモリを重視しないなら、これは省略可能です。


表記文字列(ハイパーリンク)をURL表示に一括変更
Sub myLINKURL()
'表記文字列(ハイパーリンク)をURL表示に一括変更します

Dim c As Range

For Each c In ActiveSheet.UsedRange
If c.Hyperlinks.Count = 1 Then
c.Value = c.Hyperlinks(1).Address
End If
Next
End Sub
<注>コード例ではシート使用範囲のすべてをURL表記に置き換えます。
<参考>選択範囲のみURL表記にするには
For Each c In Selection とコードを書き換えてください。


シート上のメールアドレス一覧に同じメールを送るには
<参考> A列:名前 B列:会社名 C列:メールアドレスの場合
オートフィルタで選択表示の状態なら、選択アドレスのみ送信できます
マクロを設定したコマンドボタンを作ると便利です
Option Explicit

Sub Mail送信()
Const MyAddress As String = "xxxxx@xxxmail.co.jp"
Dim ToAddress As String
Dim Target As Range, aCell As Range
Set Target = ActiveSheet.UsedRange.Columns(
3).SpecialCells(xlCellTypeVisible)
For Each aCell In Target
If InStr(aCell, "@") Then ToAddress = ToAddress & aCell.Text & ","
Next
Set aCell = Nothing
Set Target = Nothing
If ToAddress = "" Then Exit Sub
ToAddress = Left(ToAddress, Len(ToAddress) - 1)
ToAddress = "mailto:" & MyAddress & "?bcc=" & ToAddress
ToAddress = ToAddress & "&subject=お知らせ"
ActiveWorkbook.FollowHyperlink Address:=ToAddress
End Sub
<注>Columns(3) の”3”が、シート左端から数えたC列の送信先メールアドレスとなります
<注>xxxxx@xxxmail.co.jp の部分を、自分(差出人)のメールアドレスに変更します。

<参考>mailto:で件名と本文を設定する書式
mailto:xxxx@xxxmail.co.jp.?Subject=件名&body=本文


Excel Bookを添付して、アウトルックエクスプレス(OE)でメール送信するには
Sub myMAILXL()
Const Subject As String = "Excel添付メール"
Const Address As String = "
xxxxx@xxxmail.co.jp"
Const Body As String = "これは VBA による自動送信メールです"
With CreateObject("htmlfile")
ParentWindow.ClipBoardData.SetData "Text", Body
End With
With Application
If .CommandBars("Drawing").Controls(2).State = msoButtonUp _
Then .CommandBars("Drawing").Controls(2).Execute
SendKeys "+{TAB 2}^v"
Dialogs(xlDialogSendMail).Show Address, Subject
CommandBars("Drawing").Controls(2).Execute
End With
End Sub
<注>赤字部分が(宛先)メールアドレスです。
<参考>宛先・件名・本文 の既定値をセットします。


TOP / FAQ1 / FAQ2 / FAQ3 / 上へ

Copyright © 2013 TOMBO. All rights reserved.