エクセルVBA小技集


Home
このコーナーでは、
私がネットの質問掲示板でした回答や仕事で作成したプログラムの中などで、
後々使えそうなコードだということでストックしてあったものを順次紹介して行きます。 項目一覧

対象のエクセルバージョンは一応97から2002ですが、2000は持っていないので動作未確認です。
基本的に97を基準にしているので、他のバージョンでも大抵は動くのではないかと思います。
97基準ですが、2000以降から使えるSplit関数が非常に便利なため結構多く使っています。

【2013/11/29追記, 2018/2/9更新, 2019/3/3更新】
そろそろExcel97も限界かなと思われますので、
これから(#0228以降)は対象のエクセルバージョンは【一応】2016以降とします。
基本的に2016で開発しますが、他バージョンでも概ねは動くと思われます。
(むしろ動くものの方が多いと思われます。)但し、動作は未確認となります。
【追記終わり】


(=== Splitの97対応について ===
97用の簡易版Split関数を掲載しています。
97用に作ったSplit,Join,Replaceを含んだsplit97.xlaもあります。ここを右クリックし、
対象をファイルに保存してください。参照設定して使います。
簡易版Split関数又はsplit97.xla(右クリック)を必要に応じて利用してください。)


内容的には、実に些細な小技から結構実用的なものまで各種取り揃えていますが
ジャンルはさほど広範囲ではありません、私の守備範囲内のものなので限られています。^^;

なお、利用者は基本的なVBAコードの使い方を理解している方を前提にしていますので
あまり説明はしていません。またコードの使用は自己責任でお願いします。
掲載のコードを使用した結果、もし不利益が生じても私は責任を負いません。

(各表題とコードの間の文字は検索用キーワードです、但し結構適当です。^^;
検索はブラウザの標準機能を利用してください。)
Home

現在の登録数 254   登録順 名前順



top

最大公約数 ― 2つの数値の最大公約数を返す関数
 the greatest common divisor
Sub CallTest()
    Debug.Print 最大公約数(24, 96)
End Sub

Function 最大公約数(ByVal M As Long, ByVal N As Long) As Long
    If M <= 0 Or N <= 0 Then Exit Function
    
    'M>=Nに調整
    If M < N Then Swap M, N
    
    Dim Q As Long, R As Long
    Do
        Q = M \ N
        R = M Mod N
        If R = 0 Then
            最大公約数 = N
            Exit Function
        End If
        
        M = N
        N = R
    Loop
End Function

Private Sub Swap(A As Long, B As Long)
    Dim Tmp As Long
    Tmp = A
    A = B
    B = Tmp
End Sub
top

フォルダ選択ダイアログ ― ダイアログでフォルダ選択し、ファイルを順に処理する例
 フォルダの選択 フォルダーの選択 フォルダ内ファイル処理
Sub Sample()
    Dim Fld As String
    Dim Fname As String
    Dim Wb As Workbook
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            Fld = .SelectedItems(1) & "\"
        Else
            'Debug.Print "キャンセルしました。"
            Exit Sub
        End If
    End With
    
    Fname = Dir(Fld & "*.xlsx")
    Do Until Fname = ""
        'Debug.Print Fld & Fname
        Set Wb = Workbooks.Open(Fld & Fname)
        
        'Wbに対する処理
        
        Wb.Close
        Fname = Dir()
    Loop
End Sub
top

素数リスト ― 2からNまでの素数配列(添え字1から)の取得
 エラトステネスの篩  エラトステネスのふるい 最速素数アルゴリズム
'テキストファイルへの出力
Sub PnsCallTest4()
    '10億で190秒
    Dim Pns As Variant
    Dim T As Single
    Dim N As Integer, i As Long
    
    T = Timer

    '素数配列の取得
    Pns = PrimeNumbers(1 * 10 ^ 7)
    
    Debug.Print Timer - T
    
    N = FreeFile
    'デスクトップのtest.txtへ
    Open CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\test.txt" For Output As #N
    
    For i = 1 To UBound(Pns)
        Print #N, CStr(i); ","; CStr(Pns(i))
    Next
    Close #N
    
    Debug.Print Timer - T
End Sub

'シートへの書き出し
Sub PnsCallTest3()
    Dim Pns As Variant
    Dim T As Single
    
    T = Timer
    
    '素数配列の取得
    Pns = PrimeNumbers(82 * 10 ^ 4)
    
    Debug.Print Timer - T
    
    '配列をN行1列に変換してシートへ
    If UBound(Pns) >= 0 Then
'        'アドインの素を参照設定している時 (シートの限界約1600万まで可能)
'        Dim cFn As cFunction
'        Set cFn = SourceOfAddin.GetClass.FunctionClass
'        ActiveCell.Resize(UBound(Pns)).Value = cFn.Transpose2(Pns)

        'ワークシート関数で縦横変換(およそ82万(65536個)まで可能)
        ActiveCell.Resize(UBound(Pns)).Value = Application.WorksheetFunction.Transpose(Pns)
    End If
End Sub

'素数配列(添え字1から)の取得
Private Function PrimeNumbers(ByVal N As Long) As Variant
    '10^6で0.07秒、10^7で0.7秒、10^8で7.4秒、一ケタで約10倍の時間となる模様
    Dim i As Long, j As Long
    Dim Max As Long
    Dim Flg() As Boolean    'FlagPrimeNumbers
    Dim Pns() As Long       'PrimeNumbers
    Dim C As Long
    
    If N < 2 Then
        PrimeNumbers = Array()
        Exit Function
    End If
    
    'まず仮に全て素数であるとする
    ReDim Flg(1 To N)
    For i = 1 To N
        Flg(i) = True
    Next
    
    '1は素数ではない
    Flg(1) = False
    
    'チェックする最大値
    Max = Sqr(N)
    
    For i = 2 To Max
        'i番目が素数なら
        If Flg(i) Then
            'その倍数をふるい落とす
            For j = i + i To N Step i
                Flg(j) = False
            Next
        End If
    Next
    
    '素数の数を数える
    C = 0
    For i = 1 To N
        If Flg(i) Then C = C + 1
    Next
    
    '素数を配列にセット
    ReDim Pns(1 To C)
    C = 0
    For i = 1 To N
        If Flg(i) Then
            C = C + 1
            Pns(C) = i
        End If
    Next
    
    PrimeNumbers = Pns
End Function
top

ガントチャートの整形 ― 図形の左右の端を、セルの近い方の枠線に合わせる
 フィット 磁石 整える 図形両端 フィッティング
※下記コードはシート内すべての図形が対象
Sub FitToCell()
    Dim Shp As Shape
    Dim X0 As Double, X1 As Double
    
    For Each Shp In ActiveSheet.Shapes   'すべての図形が対象
        X0 = NearX(Shp.TopLeftCell, Shp.Left)
        X1 = NearX(Shp.BottomRightCell, Shp.Left + Shp.Width)
        If X0 = X1 Then
        Else
            Shp.Left = X0
            Shp.Width = X1 - X0
        End If
    Next
End Sub

Private Function NearX(R As Range, X As Double) As Double
    Dim X0 As Double, X1 As Double
    X0 = R.Left
    X1 = X0 + R.Width
    If X < X0 Then
        NearX = X0
    ElseIf X > X1 Then
        NearX = X1
    Else
        If (X - X0) / (X1 - X0) < 0.5 Then
            NearX = X0
        Else
            NearX = X1
        End If
    End If
End Function
top

カレントディレクトリの変更 ― ネットワークパスをカレントディレクトリにする
 ChDir CurDir パス変更 現在のフォルダ
CreateObject("WScript.Shell").CurrentDirectory =ネットワークパス
top

WordVBA 検索の一例 ― MicrosoftWordのVBA、検索の一例(ExcelVBAではない)
 ワードVBA MSWord ワードのRange
'WordVBA 検索の一例(文字検索、それを含む段落+下2段落を選択)
Sub WordのFindメソッド()
    Dim RR As Word.Range
    
    Set RR = ActiveDocument.Content
    
    '※Findメソッドを実行すると対象のRangeは見つけたものに置き換わる
    With RR.Find
        .ClearFormatting
        .MatchFuzzy = True
        .Text = "検索文字列"
        If .Execute Then
            '段落に拡張
            RR.Expand wdParagraph
            'さらに2段落下まで拡張
            Set RR = ActiveDocument.Range(RR.Start, RR.Next(wdParagraph, 2).End)
        Else
            Set RR = Nothing
        End If
    End With
    
    If Not RR Is Nothing Then
        RR.Select
    Else
        MsgBox "NotFound", vbExclamation
    End If
End Sub
top

セルの塗りつぶし色をRGBに分解 ― 【色】をRGBに分解する 赤(255)==>255,0,0 緑(65280)==>0,255,0 青(16711680)==>0,0,255
 色分解 色コード 色番号
Sub test()
    MsgBox Color2RGB(ActiveCell.Interior.Color)
End Sub

'セルの塗りつぶし色をRGBに分解
Function Color2RGB(ColorNumber As Long) As String
    Dim R As Long, G As Long, B As Long
    R = ColorNumber Mod 256
    G = ColorNumber \ 256 Mod 256
    B = ColorNumber \ 256 \ 256 Mod 256
    Color2RGB = CStr(R) & "," & CStr(G) & "," & CStr(B)
End Function
top

カウントダウンタイマー ― ユーザーフォームで表示するカウントダウンタイマー
 ※必要な準備 UserForm1, Label1(Labelの書式は適宜)
'===== UserForm1モジュール =====
Private Sub UserForm_Initialize()
    LimitTime = Now + TimeSerial(0, 3, 0)   '設定時間
    CountDown
End Sub

Private Sub UserForm_Terminate()
    On Error Resume Next
    Application.OnTime NextTime, "CountDown", , False
End Sub

'=====標準モジュール =====
Option Explicit

Public LimitTime As Date
Public NextTime As Date

Sub Start()
    UserForm1.Show vbModeless
End Sub

Sub CountDown()
    NextTime = Now + TimeSerial(0, 0, 1)
    UserForm1.Label1.Caption = Format$(LimitTime - Now, "nn:ss")
    
    If Now >= LimitTime Then
        MsgBox "時間です。", vbExclamation
        Unload UserForm1
    Else
        Application.OnTime NextTime, "CountDown"
    End If
End Sub
top

多階層フォルダ作成 ― 【アドインの素】の機能で多階層のフォルダを一気に作成する
 フォルダ作成実用版 深い階層 一度に
'※「アドインの素」への参照設定が必要です。
' http://hp.vector.co.jp/authors/VA033788/addinsample.html
' http://hp.vector.co.jp/authors/VA033788/softmenu.html#017
' https://www.vector.co.jp/soft/winnt/business/se503721.html

Sub CallSample()
    Dim Fld As String
    Fld = CreateObject("WScript.Shell").SpecialFolders("DeskTop")
    Fld = Fld & "\test\test1\test2\test3\test4"
    If MakeFolder2(Fld) Then MsgBox "ok"
End Sub

'多階層フォルダ作成
Function MakeFolder2(ByVal Fld As String) As Boolean
    '作成成功or既存 True 失敗 False
    Dim cGA As cGetAttr
    Dim ErrMsg As String
    
    Set cGA = SourceOfAddin.GetClass.GetAttrClass
    MakeFolder2 = cGA.MakeDir(Fld, ErrMsg)
    If ErrMsg <> "" Then
        MsgBox ErrMsg, vbExclamation
    End If
    Set cGA = Nothing
End Function
top

フォルダ作成(簡易版) ― 指定フォルダがあるか確認し、無い時は作成する
 ディレクトリ作成 一階層のみ 同名ファイルがある時はエラー ファイル属性
Sub CallSample()
    Dim Fld As String
    Fld = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\test"
    MakeFolder Fld
End Sub

'フォルダ作成(無い時に作成、既存の時は何もしない)
Sub MakeFolder(ByVal Fld As String)
    Dim Res As VbFileAttribute
    On Error Resume Next
    Res = GetAttr(Fld) And vbDirectory
    On Error GoTo 0
    If Res <> vbDirectory Then
        MkDir Fld
    End If
End Sub
top

RangeTo一次元配列 ― RangeのValueを一次元配列に変換する(引数のRangeは任意の数指定可能)
 セル範囲から一次元配列 複数のセル範囲
Sub test()
    Dim VV As Variant
    Dim V As Variant
    
    VV = RangeToAry(Selection, Range("e3:e4"), Range("c18,d19,g4"))
    For Each V In VV
        Debug.Print V
    Next
End Sub

'RangeのValueを一次元配列に変換
Function RangeToAry(Rng1 As Range, ParamArray RngOther()) As Variant
    Dim RR As Range
    Dim Ary() As Variant
    Dim C As Long
    Dim i As Long
    
    RangeToArySub ToUsedRange(Rng1), Ary(), C
    
    For i = LBound(RngOther) To UBound(RngOther)
        RangeToArySub ToUsedRange(RngOther(i)), Ary(), C
    Next
    
    RangeToAry = Ary()
End Function

'行又は列全体の時は使用範囲内に絞る
Private Function ToUsedRange(ByVal RR As Range) As Range
    If RR.Rows.Count = RR.Worksheet.Rows.Count Then
        Set RR = Intersect(RR, RR.Worksheet.UsedRange)
    End If
    If RR.Columns.Count = RR.Worksheet.Columns.Count Then
        Set RR = Intersect(RR, RR.Worksheet.UsedRange)
    End If
    Set ToUsedRange = RR
End Function

Private Sub RangeToArySub(ByVal Rng As Range, ByRef Ary() As Variant, ByRef C As Long)
    Dim Are As Range
    Dim VV As Variant
    Dim V As Variant
    Dim N As Long
    
    For Each Are In Rng.Areas
        N = Are.Cells.Count
        ReDim Preserve Ary(1 To C + N)
        
        If N = 1 Then
            C = C + 1
            Ary(C) = Are.Value
        Else
            VV = Are.Value
            For Each V In VV
                C = C + 1
                Ary(C) = V
            Next
        End If
    Next
End Sub
top

ファイル名を連番に ― 【アドインの素】を利用して取得したフルパスリストを使いファイル名を連番にする
 連続番号 ファイル名変更 ファイルリスト リネーム
'※「アドインの素」への参照設定が必要です。
' http://hp.vector.co.jp/authors/VA033788/addinsample.html
' http://hp.vector.co.jp/authors/VA033788/softmenu.html#017
' https://www.vector.co.jp/soft/winnt/business/se503721.html

Sub ReNameFiles()
    Dim cFL As cFileList2
    Dim cFn As cFunction
    Dim Fpaths As Variant
    Dim C As Long, N As Variant
    Dim fromPath As String
    Dim toPath As String
    Dim i As Long
    
    Set cFL = SourceOfAddin.GetClass.FileList2Class
    Set cFn = SourceOfAddin.GetClass.FunctionClass
    
    'フルパスリスト取得
    With cFL
        .SearchPattern = "*.jpg"   'ファイルの検索パターン
        .Execute .DeskTopPath & "\Data"  '引数のパスに対して検索実行
        Fpaths = .FullNames
        C = .Count
    End With
    
    '桁数
    N = Int(Log(C) / Log(10)) + 1
    N = String$(N, "0")
    
    'リネーム
    For i = 0 To UBound(Fpaths)
        fromPath = Fpaths(i)
        toPath = Replace(fromPath, cFn.FileNameOnly(fromPath), Format$(i + 1, N))
        Name fromPath As toPath
    Next
    
    Set cFL = Nothing
    Set cFn = Nothing
End Sub
top

線引き ― セルを基準にしてワークシート上に図形の線を引く関数
 ライン 描画 セル単位 セル間に線 Shape Line
Sub test()
    DrawLine Range("B2"), 0, 0, Range("H2"), 0, 0
    DrawLine Range("C3"), 50, 50, Range("J3"), 50, 50
    With DrawLine(Range("A5"), 0, 50, Range("G5"), 70, 50).Line
        .ForeColor.RGB = vbBlack
        .Weight = 3
        .EndArrowheadStyle = msoArrowheadOpen
    End With
End Sub

Sub test2()
    DL2 "A1", "C5"
    DL2 "C5", "D15"
    DL2 "D15", "H3"
    DL2 "H3", "A1"
End Sub

'セル中央に線を引く
Sub DL2(ByVal S As String, ByVal E As String)
    DrawLine Range(S), 50, 50, Range(E), 50, 50
End Sub

'線引き(開始セル、そのX方向%、Y方向%、終了セル、そのX方向%、Y方向%)
Function DrawLine(ByVal rngS As Range, ByVal PsX As Single, ByVal PsY As Single _
    , ByVal rngE As Range, ByVal PeX As Single, ByVal PeY As Single) As Shape

    Dim X1 As Single, Y1 As Single
    Dim X2 As Single, Y2 As Single
    Dim W As Single, H As Single
    
    With rngS
        W = .Width: H = .Height
        X1 = .Left + W * PsX / 100
        Y1 = .Top + H * PsY / 100
    End With
    
    With rngE
        W = .Width: H = .Height
        X2 = .Left + W * PeX / 100
        Y2 = .Top + H * PeY / 100
    End With
    
    Set DrawLine = rngS.Worksheet.Shapes.AddLine(X1, Y1, X2, Y2)
End Function
top

確率乱数 ― 指定確率(割合)の乱数を得る関数(下記コードの指定では、1,2,3,4に対して5,6,7,8が2倍の確率で返る)
 確率指定 確率を指定 比率指定乱数 Array(1,3,1)なら、1,3に対して2が3倍の確率
'確率乱数
Function Rand2() As Long
    Static Flg As Boolean   '初期化済みフラグ
    Static Ratio As Variant
    Dim i As Long
    Dim Z As Double
    Dim V As Single
    Dim N As Long
    
    If Not Flg Then
        '比率
        Ratio = Array(1, 1, 1, 1, 2, 2, 2, 2)
        
        '合計
        For i = LBound(Ratio) To UBound(Ratio)
            Z = Z + Ratio(i)
        Next
        '比率計算
        For i = LBound(Ratio) To UBound(Ratio)
            Ratio(i) = Ratio(i) / Z
        Next
        'しきい値
        For i = LBound(Ratio) + 1 To UBound(Ratio)
            Ratio(i) = Ratio(i - 1) + Ratio(i)
        Next
        
        Randomize
    
        Flg = True
    End If
        
    V = Rnd()
    
    For i = LBound(Ratio) To UBound(Ratio)
        If V < Ratio(i) Then
            N = i - LBound(Ratio) + 1
            Exit For
        End If
    Next
    
    Rand2 = N
End Function
top

次の入力セル ― 指定のトップセルからみて次の空セルを返す(後ろから検索)
 次入力 最後のセル 最終セルの次 入力位置 他シート、他ブック
Sub CallSample()
    Dim R As Range
    Set R = Worksheets("Sheet2").Range("B2")
    Set R = GetNextCell(R)
    
    '確認
    Application.Goto R
End Sub

'指定のトップセルからみて次の空セルを返す(シート最下行から上方を検索)
Function GetNextCell(ByVal rngTop As Range) As Range
    Dim R As Range
    
    Set R = rngTop.Cells(1)
    Set R = R.EntireColumn
    
    Set R = R.Cells(R.Cells.Count).End(xlUp)
    
    If R.Row < rngTop.Row Then
        Set R = rngTop.Cells(1)
    End If
    
    If Not IsEmpty(R.Value) Then
        Set R = R.Offset(1)
    End If
    
    Set GetNextCell = R
End Function

'指定のトップセルからみて次の空セルを返す(シート最右列から左方向を検索)
Function GetNextCell2(ByVal rngTop As Range) As Range
    Dim R As Range
    
    Set R = rngTop.Cells(1)
    Set R = R.EntireRow
    
    Set R = R.Cells(R.Cells.Count).End(xlToLeft)
    
    If R.Column < rngTop.Column Then
        Set R = rngTop.Cells(1)
    End If
    
    If Not IsEmpty(R.Value) Then
        Set R = R.Offset(, 1)
    End If
    
    Set GetNextCell2 = R
End Function
top

入力済セル範囲(一列又は一行) ― 指定セルから最下行又は最右列までのセル範囲を返す(後方から検索)
 処理対象範囲 複数シート対応 複数ブック対応 他シート、他ブック 汎用的な範囲取得
Sub CallSample()
    Dim RR As Range
    Set RR = Worksheets("Sheet2").Range("B2")
    Set RR = GetColumn(RR)
    
    '確認
    Application.Goto RR
End Sub

'指定のトップセルから最下行までのセル範囲を返す(シート最下行から上方を検索)
Function GetColumn(ByVal rngTop As Range) As Range
    Dim RR As Range
    
    Set RR = rngTop.Cells(1)
    Set RR = RR.EntireColumn
    
    Set RR = RR.Cells(RR.Cells.Count).End(xlUp)
    
    If RR.Row < rngTop.Row Then
        Set RR = rngTop.Cells(1)
    Else
        Set RR = RR.Worksheet.Range(rngTop, RR)
    End If
    
    Set GetColumn = RR
End Function


'指定のトップセルから最右列までのセル範囲を返す(シート最右列から左方を検索)
Function GetRow(ByVal rngTop As Range) As Range
    Dim RR As Range
    
    Set RR = rngTop.Cells(1)
    Set RR = RR.EntireRow
    
    Set RR = RR.Cells(RR.Cells.Count).End(xlToLeft)
    
    If RR.Column < rngTop.Column Then
        Set RR = rngTop.Cells(1)
    Else
        Set RR = RR.Worksheet.Range(rngTop, RR)
    End If
    
    Set GetRow = RR
End Function
top

文字列&数字列、の次の番号を返す ― ABC0012なら次はABC0013という次の番号を返す
 次番号 正規表現 文字&数字 文字と数字
Sub Sample0()
    Dim R As Range
    Dim i As Long
    
    Set R = Range("E4")
    
    For i = 1 To 5
        MsgBox R.Value
        R.Value = NextNumber(R.Value)
    Next
    
    NextNumber ""
End Sub

'文字列&数字列、の次の番号を返す
Private Function NextNumber(ByVal Num As String) As String
    Static Reg As Object    'RegExp
    Dim Mtc As Object       ' Match
    Dim sMtcs As Object     ' SubMatches
    Dim strS As String
    Dim strN As String
    Dim N As Long
    
    If Num = "" Then
        Set Reg = Nothing
        Exit Function
    End If
    
    If Reg Is Nothing Then
        Set Reg = CreateObject("VBScript.RegExp")
    End If
    
    With Reg
        .Pattern = "(\D+)(\d+)"
        
        Set Mtc = .Execute(Num)(0)
        Set sMtcs = Mtc.SubMatches
        
        strS = sMtcs(0)
        strN = sMtcs(1)
        
        N = CLng(strN) + 1
        strS = strS & Format$(N, String$(Len(strN), "0"))
                    
    End With
    
    NextNumber = strS
End Function
top

サブフォルダを含むファイルリストの取得 ― 【アドインの素】を利用した、フルパスリスト取得サンプル
 サブディレクトリ ファイル一覧 ファイル種別複数指定 ファイルサーチ
'※「アドインの素」への参照設定が必要です。
' http://hp.vector.co.jp/authors/VA033788/addinsample.html
' http://hp.vector.co.jp/authors/VA033788/softmenu.html#017
' https://www.vector.co.jp/soft/winnt/business/se503721.html

Sub CallSample()
    Dim Fpath As String
    Dim FList As Variant
    
    '検索するフォルダ
    Fpath = cFL2.MyDocumentsPath
    
    'ファイルリスト取得
    FList = GetFileList(Fpath)
    
    If cFL2.Count = 0 Then
        MsgBox "ファイルが見つかりません。", vbExclamation
        Exit Sub
    End If

    '新規ワークシートに表示
    With cFL2
        Workbooks.Add.Worksheets(1).Range("A1").Resize(.Count) _
            .Value = .Transpose2(.FullNames)
        ActiveWorkbook.Saved = True
    End With
End Sub

'サブフォルダを含むファイルリスト(フルパス)を取得
Private Function GetFileList(TopFolder As String) As Variant
    With cFL2
        .SearchPattern = "*.xls;*.xla;*.xlsx;*.xlsm"  '複数指定可
        .SearchSubFolders = True
        .Execute TopFolder, SortBy:=msoSortByNone 'Sort指定は他にファイル名、フルパス、更新日付など
        GetFileList = .FullNames    'ファイル名だけなら.Fnames
    End With
End Function

'ファイルリスト取得クラス
Private Function cFL2() As cFileList2
    Static cFL As cFileList2
    If cFL Is Nothing Then
        Set cFL = SourceOfAddin.GetClass.FileList2Class
    End If
    Set cFL2 = cFL
End Function
top

フォルダ内画像を更新日順にシートへ貼り付け ― 機能毎にプロシージャを分けた、画像貼り付けのコード例
 画像貼付 写真貼り付け 更新日付順 縦一列 サイズ変更なし 元の大きさのまま
Sub LoadPictureLight()
    Dim Fld As String
    Dim Fname As String
    Dim Fnames() As String
    Dim Times() As Date
    Dim Ndx As Variant
    Dim C As Long
    Dim i As Long
    Dim rngD As Range
    Dim Pic As Shape
    
    If Not GetFolder(Fld) Then Exit Sub
    Fld = Fld & "\"
    
    Fname = Dir(Fld & "*.*")
    Do Until Fname = ""
        If IsTarget(Fname) Then
        
            C = C + 1
            ReDim Preserve Fnames(1 To C)
            ReDim Preserve Times(1 To C)
            
            Fnames(C) = Fname
            Times(C) = FileDateTime(Fld & Fname)
            
        End If
        
        Fname = Dir()
    Loop
    If C = 0 Then
        MsgBox "対象ファイルがありません。", vbExclamation
        Exit Sub
    End If
    
    Ndx = MsCombSortI(Times)
    
    '貼付け先の最初のセル
    Set rngD = Range("A1")
    
    For i = 1 To C
        Fname = Fnames(Ndx(i))
        
        Set Pic = ActiveSheet.Shapes.AddPicture(Fld & Fname, msoFalse, msoTrue, rngD.Left, rngD.Top, 0, 0)
        Pic.ScaleWidth 1, RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromTopLeft
        Pic.ScaleHeight 1, RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromTopLeft
        
        Set rngD = Intersect(rngD.EntireColumn, Pic.BottomRightCell.EntireRow).Offset(2)
    Next
End Sub

Private Function IsTarget(Fname As String) As Boolean
    Dim Ext As String
    Dim i As Long
    
    i = InStrRev(Fname, ".")
    If i >= 1 Then
        Ext = Mid$(Fname, i + 1)
    End If
    Ext = LCase(Ext)
    
    Select Case Ext
        '画像ファイルの拡張子(小文字)
        Case "jpg", "jpeg", "bmp", "gif", "png"
            IsTarget = True
    End Select
End Function

'処理対象フォルダ選択
Private Function GetFolder(Fld As String) As Boolean
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "処理対象フォルダを選択してください。"
        If .Show Then
            Fld = .SelectedItems(1)
            GetFolder = True
        Else
            GetFolder = False
        End If
    End With
End Function

Private Function MsCombSortI(Ary As Variant) As Variant
    '昇順インデックスを返す
    '配列引数Aryは1次元限定
    Dim Idx() As Long
    Dim L As Long
    Dim U As Long
    Dim i As Long
    Dim gap As Long
    Dim Temp As Long
    Dim F As Boolean
    
    L = LBound(Ary)
    U = UBound(Ary)
    
    'インデックス初期設定
    ReDim Idx(L To U)
    For i = L To U
        Idx(i) = i
    Next
    
    gap = U - L
    F = True
    
    '並べ替え
    Do While gap > 1 Or F = True
        gap = Int(gap / 1.3)
        If gap = 9 Or gap = 10 Then
            gap = 11
        ElseIf gap < 1 Then
            gap = 1
        End If
        
        F = False
        For i = L To U - gap
            If Ary(Idx(i)) > Ary(Idx(i + gap)) Then  '降順時は <
            
                Temp = Idx(i)
                Idx(i) = Idx(i + gap)
                Idx(i + gap) = Temp
                F = True
                
            ElseIf Ary(Idx(i)) = Ary(Idx(i + gap)) Then
            
                If Idx(i) > Idx(i + gap) Then   '昇順降順変更しても変更の必要なし
                    Temp = Idx(i)
                    Idx(i) = Idx(i + gap)
                    Idx(i + gap) = Temp
                    F = True
                End If
                
            End If
        Next
    Loop

    MsCombSortI = Idx()
End Function
top

オートフィルタで種類毎に印刷 ― 特定項目の種類数分すべてを、オートフィルタを掛けながら印刷する
 種類ごと 全種類 フィルタで印刷 種別毎
Sub PrintAutoFilter()
    Dim rngAF As Range
    Dim RR As Range
    Dim R As Range
    Dim VV As Variant
    Dim V As Variant
    Const KeyColumn As Long = 4 'キー列
    
    If Not ActiveCell.Worksheet.AutoFilterMode Then Exit Sub
    Set rngAF = ActiveCell.Worksheet.AutoFilter.Range
    
    'オートフィルタのフィルタリセット
    rngAF.Worksheet.AutoFilter.ShowAllData
    
    'キー列データ
    Set RR = rngAF.Columns(KeyColumn)
    Set RR = Intersect(RR, RR.Offset(1))
    VV = GetSummary(RR)
    
    '印刷ループ
    For Each V In VV
        rngAF.AutoFilter KeyColumn, V
        rngAF.PrintPreview
        'rngAF.PrintOut     '実際の印刷時にはこちらを有効にする
    Next
    
    'オートフィルタのフィルタリセット
    rngAF.Worksheet.AutoFilter.ShowAllData
End Sub

'Rangeを受け、重複の無い一次元配列(添え字0ベース)を返す
Private Function GetSummary(RR As Range) As Variant
    '返す配列の添え字下限は0
    Dim R As Range
    Dim Dic As Object
    Dim K As Variant
    Dim V As Variant
    
    Set Dic = CreateObject("Scripting.Dictionary")
    For Each R In RR.Cells
        K = R.Value
        If K <> "" Then
            Dic(K) = Empty
        End If
    Next
    V = Dic.keys
    Set Dic = Nothing
    
    GetSummary = V
End Function
top

ふりがな ― セルのふりがなの使用例
 フリガナ 振り仮名
activecell.Phonetic.Text ="エーエーエー"
activecell.Phonetic.Visible=true
activecell.Phonetics.Count
activecell.SetPhonetic

Sub test()
    Dim Pho As Excel.Phonetics
    
    For Each Pho In ActiveCell.Phonetics
        Debug.Print Pho.Text, Pho.Start, Pho.Length
    Next
End Sub

Sub test2()
    Dim Phs As Phonetics
    Dim Ph As Phonetics
    
    Set Phs = ActiveCell.Phonetics
    For Each Ph In Phs
        With ActiveCell.Offset(2)
            .Characters(Ph.Start, Ph.Length).PhoneticCharacters = Ph.Text
        End With
    Next
End Sub


top

図形範囲取得 ― セル範囲の中に左上が含まれている図形範囲(ShapeRange)を返す
 セル範囲中の写真 セル中の図形 セルに含まれる図形 セル領域内の図形 セル領域内の写真
Sub CallTest()
    Dim Shps As ShapeRange
    Dim Shp As Shape
    Set Shps = GetShapes(Range("A1:H20"))
    If Not Shps Is Nothing Then
        For Each Shp In Shps
            Debug.Print Shp.Name
        Next
    Else
        Debug.Print "Not Found"
    End If
End Sub

'セル範囲の中に左上が含まれている図形範囲を返す
Public Function GetShapes(Rng As Range, Optional PictureOnly As Boolean = False) As ShapeRange
    Dim Ndx() As String
    Dim C As Long
    Dim Shp As Shape
    C = 0
    For Each Shp In Rng.Worksheet.Shapes
        If Not Application.Intersect(Shp.TopLeftCell, Rng) Is Nothing Then
            If PictureOnly Then
                If Shp.Type = msoPicture Then
                    C = C + 1
                    ReDim Preserve Ndx(1 To C)
                    Ndx(C) = Shp.Name
                End If
            Else
                C = C + 1
                ReDim Preserve Ndx(1 To C)
                Ndx(C) = Shp.Name
            End If
        End If
    Next
    If C >= 1 Then
        Set GetShapes = Rng.Worksheet.Shapes.Range(Ndx)
    Else
        Set GetShapes = Nothing
    End If
End Function
top

十字セレクト ― 選択行、選択列が分かり易くなるように、選択セルの行と列を反転表示する
 選択行に色付け 選択行を色塗り 選択行を見易く
'===== ThisWorkbookモジュール =====
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    'Sheet1でのみ動作させる
    If Sh.Name <> "Sheet1" Then Exit Sub    '<===適宜変更
    
    '一セル以上の選択なら抜ける
    If Target.Cells.Count >= 2 Then Exit Sub
    
    '動作セル範囲
    Dim Rng As Range
    Set Rng = Target.Worksheet.Range("B3:H23")  '<===適宜変更
    
    '範囲外なら抜ける
    If Intersect(Target, Rng) Is Nothing Then Exit Sub
    
    '十字セレクト
    Dim R As Range, C As Range
    Set R = Target.EntireRow
    Set C = Target.EntireColumn
    Intersect(Union(R, C), Rng).Select
    Target.Activate
End Sub
top

右クリックで独自リスト表示 ― セルへの選択入力をする為に右クリックで独自のリスト(CommandBarPopup)を表示する
 入力規則の代わり 自前のリスト 自前のポップアップ 右クリック制御
'===== ThisWorkbookモジュール =====
Option Explicit

'アプリケーションレベルのイベントで全ブックで使用可能にする
Private WithEvents myExl As Application

'このブックのプロジェクト名と同じ値を設定すること
Private Const myProjectName As String = "myPrj" '★重要

'機能を有効にするにはブックを開き直すかここを実行する
Private Sub Workbook_Open()
    Set myExl = Application
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set myExl = Nothing
End Sub

Private Sub myExl_SheetBeforeRightClick _
    (ByVal Sh As Object, ByVal Target As Range _
    , Cancel As Boolean)

    '動作箇所の制限
    If Target.Column <> 1 Then Exit Sub
    
    Dim myBar As CommandBar
    Dim myList As Variant
    Dim V As Variant
    
    '本来の右クリックを表示しない
    Cancel = True
    
    '設定するリストのデータ
    myList = Array("Data1", "Data2", "Data3")
    
    '一時的にポップアップを作成
    Set myBar = Application.CommandBars.Add _
        (Name:="Temp", Position:=msoBarPopup, temporary:=True)
    
    'リストの設定
    For Each V In myList
        With myBar.Controls.Add(Type:=msoControlButton, temporary:=True)
            .Caption = V
            .OnAction = myProjectName & ".ThisWorkbook.選択"
        End With
    Next
    
    'リスト表示
    myBar.ShowPopup
    
    '後始末
    myBar.Delete
    Set myBar = Nothing
End Sub

'リスト選択時に実際に動作するプロシージャ
Private Sub 選択()
    Dim D As String
    'クリックされたコントロールのCaption
    D = Application.CommandBars.ActionControl.Caption
    MsgBox D
End Sub
top

オートフィルタ後のデータコピー ― オートフィルタ実行後の、タイトルを除くフィルタされたデータのみをコピーする
 AutoFilter オートフィルター タイトル以外 タイトル除去 フィルタデータ DataOnly
Sub Sample()
    Dim RR As Range
    Set RR = ActiveCell.Worksheet.AutoFilter.Range
    Set RR = Intersect(RR.SpecialCells(xlCellTypeVisible), RR.Offset(1))
    RR.Copy 貼り付け先セル
End Sub
top

シートへのハイパーリンク ― 各シートへのハイパーリンクを一覧表シートに設定する(各シートからの「戻る」も)
 目次 ハイパーリンクリスト ハイパーリンク一覧 シート一覧
'一覧表シートに各シートへのハイパーリンクリストを設定する(各シートからの「戻る」も)
Private Sub SetHyperlinks()
    Dim wsMain As Worksheet
    Dim Sht As Worksheet
    Dim ShtNames() As String
    Dim Na As String
    Dim C As Long, i As Long
    Dim R As Range

    Const TopCellAddress As String = "B2"
    Const adr一覧表に戻る As String = "H1"
    Const MaxRow As Long = 10
    Const RowStep As Long = 2
    Const ColStep As Long = 2
    
    Set wsMain = Worksheets(1)    '一覧表シート
    
    '既存リストクリア
    wsMain.UsedRange.Clear

    'シート名配列
    C = 0
    For Each Sht In wsMain.Parent.Worksheets
        If Sht.Name = wsMain.Name Then  '一覧表を除く
        Else
            C = C + 1
            ReDim Preserve ShtNames(1 To C)
            ShtNames(C) = Sht.Name
        End If
    Next
'    'シート名並べ替え
'    ShtNames = Csort(ShtNames)

    'ハイパーリンク設定
    Set R = wsMain.Range(TopCellAddress)
    For i = 1 To UBound(ShtNames)
        Na = ShtNames(i)
        Set Sht = wsMain.Parent.Worksheets(Na)
        
        '一覧表
        wsMain.Hyperlinks.Add anchor:=R, Address:="", _
            SubAddress:="'" & Na & "'!A1", _
            TextToDisplay:="'" & Na
        '戻る
        With Sht
            .Range(adr一覧表に戻る).MergeArea.ClearContents
            .Hyperlinks.Add anchor:=.Range(adr一覧表に戻る), Address:="", _
                SubAddress:="'" & wsMain.Name & "'!" & R.Address(0, 0, xlA1, 0), _
                TextToDisplay:="一覧表に戻る"
            .Range(adr一覧表に戻る).Font.Size = 11
        End With

        '次の位置
        If i Mod MaxRow = 0 Then
            Set R = R.Offset(-(MaxRow - 1) * RowStep, ColStep)
        Else
            Set R = R.Offset(RowStep)
        End If

    Next
    '一覧表フォントサイズ
    wsMain.UsedRange.Font.Size = 11
End Sub

Private Function Csort(ByVal Ary As Variant) As Variant
    '昇順並べ替え、引数は1次元配列のみ可。
    Dim L As Long
    Dim U As Long
    Dim i As Long
    Dim gap As Long
    Dim Temp As Variant
    Dim F As Boolean
    
    L = LBound(Ary)
    U = UBound(Ary)
    gap = U - L
    F = True
    
    Do While gap > 1 Or F = True
        gap = Int(gap / 1.3)
        If gap = 9 Or gap = 10 Then
            gap = 11
        ElseIf gap < 1 Then
            gap = 1
        End If
        F = False
        For i = L To U - gap
            If Ary(i) > Ary(i + gap) Then
                Temp = Ary(i)
                Ary(i) = Ary(i + gap)
                Ary(i + gap) = Temp
                F = True
            End If
        Next
    Loop
    
    Csort = Ary
End Function
top

ブック固有データの保存 ― シートを使用せず、[ファイル] - [プロパティ] - 「ユーザー設定」を利用
 カスタムドキュメントプロパティ ブックにデータを保存 シート不使用で値保持 ※文字(テキスト)データのみ
'ブックの指定省略時はアクティブブックが対象
Sub test1()
    CDPLet "Name1", "Value1"
    MsgBox CDPGet("Name1")
End Sub

'ブックを明示的に指定も可能
Sub test2()
    CDPLet "Name2", "Value2", Workbooks("book2.xls")
    MsgBox CDPGet("Name2", Workbooks("book2.xls"))
End Sub

Public Sub CDPLet(PName As String, PValue As String, Optional ByVal Book As Workbook)
    CheckCustomDocumentProperty PName, Book
    Book.CustomDocumentProperties(PName).Value = PValue
End Sub

Public Function CDPGet(PName As String, Optional ByVal Book As Workbook) As String
    CheckCustomDocumentProperty PName, Book
    CDPGet = Book.CustomDocumentProperties(PName).Value
End Function

Private Sub CheckCustomDocumentProperty(CDPname As String, Book As Workbook)
    Dim Flg As Boolean
    Dim i As Long
    
    If Book Is Nothing Then
        Set Book = ActiveWorkbook
    End If

    With Book.CustomDocumentProperties
        For i = 1 To .Count
            If .Item(i).Name = CDPname Then
                Flg = True
                Exit For
            End If
        Next
        If Not Flg Then
            .Add Name:=CDPname, LinkToContent:=False, _
                Type:=msoPropertyTypeString, Value:=""
        End If
    End With
End Sub
top

データ処理、列範囲の取得 ― 指定セルから最終行(そのシートの最終使用行)までの「1列」を返す
 データ処理範囲 列取得 データ列 データの最終行 処理データ範囲
Sub test()
    GetColumn(Range("A5")).Select
End Sub

'指定セルから最終行(そのシートの最終使用行)までの「1列」を返す
Function GetColumn(TopCell As Range) As Range
    Dim RR As Range
    With TopCell.Worksheet
        Set RR = Intersect(TopCell.EntireColumn, .UsedRange)
        Set RR = .Range(TopCell, RR.Rows(RR.Rows.Count))
    End With
    Set GetColumn = RR
End Function
top

オートフィルタ▼表示・非表示 ― オートフィルタの▼ボタンを任意に表示・非表示に切り替える
 オートフィルタボタン非表示 ▼ボタン非表示 ドロップダウン任意表示
Sub ▼任意表示()
    Dim Afl As AutoFilter
    Dim Ary As Variant
    Dim i As Variant
    
    Ary = Array(1, 9)   '表示する列
    Set Afl = ActiveSheet.AutoFilter    'オートフィルタは事前に設定済の前提
    
    '一旦すべて非表示
    For i = 1 To Afl.Filters.Count
        Afl.Range.AutoFilter i, VisibleDropDown:=False
    Next
    
    '任意に表示
    For Each i In Ary
        Afl.Range.AutoFilter i, VisibleDropDown:=True
    Next
End Sub
top

コントロール配列クラス ― ユーザーフォームのコントロールを配列で扱うクラス(イベント処理を含む)
 コントロール配列 イベントクラス レイズイベント 二重クラス
※Excel2000以上
※とりあえず、コマンドボタン・チェックボックス・オプションボタンのクリック、テキストボックスのチェンジの4イベントのみ ^d^

===== UserForm1 モジュール =====
Option Explicit

Private WithEvents cMyButtons As cCtrls

'クラスのコマンドボタンクリックイベントで一括処理
Private Sub cMyButtons_CmdClick(ByVal Ctrl As MSForms.CommandButton, ByVal Index As Long, ByVal Container As MSForms.Control)
    Dim Msg As String
    With Ctrl
        Msg = "Caption=" & .Caption & vbCrLf
    End With

    Msg = Msg & "Index=" & Index & vbCrLf

    With Container
        Msg = Msg & "Name=" & .Name & vbCrLf
        Msg = Msg & "TabIndex=" & .TabIndex & vbCrLf
        Msg = Msg & "Left=" & .Left & vbCrLf
        Msg = Msg & "Top=" & .Top & vbCrLf
    End With
    MsgBox Msg
End Sub

Private Sub UserForm_Initialize()
    Dim Ctrl As MSForms.Control
    
    Set cMyButtons = New cCtrls
    
    'フォーム上のコマンドボタンをクラスに追加する
    For Each Ctrl In Me.Controls
        If TypeName(Ctrl) = "CommandButton" Then
            If Ctrl.Caption = "OK" Or Ctrl.Caption = "キャンセル" Then
            Else
                cMyButtons.AddCtrl Ctrl
            End If
        End If
    Next
End Sub

Private Sub UserForm_Terminate()
    Set cMyButtons = Nothing
End Sub


===== cCtrls クラスモジュール =====
Option Explicit
'Excel2000以上
'Microsoft Forms 2.0 Object Library への参照設定要(UserFormを挿入すれば自動的に設定される)
'最終更新日:'11/10/27

Public Event TxtChange(ByVal Ctrl As MSForms.TextBox, ByVal Index As Long, ByVal Container As MSForms.Control)
Public Event CmdClick(ByVal Ctrl As MSForms.CommandButton, ByVal Index As Long, ByVal Container As MSForms.Control)
Public Event ChkClick(ByVal Ctrl As MSForms.CheckBox, ByVal Index As Long, ByVal Container As MSForms.Control)
Public Event OptClick(ByVal Ctrl As MSForms.OptionButton, ByVal Index As Long, ByVal Container As MSForms.Control)
    
Private myCtrls() As cCtrl
Private myCount As Long

Public Property Get Item(Index As Long) As MSForms.Control
    If Index >= 0 And Index < myCount Then
        Set Item = myCtrls(Index).Control
    End If
End Property

Public Property Get Count() As Long
    Count = myCount
End Property

Public Sub AddCtrl(Ctrl As MSForms.Control)
    ReDim Preserve myCtrls(0 To myCount)
    Set myCtrls(myCount) = New cCtrl
    myCtrls(myCount).SetCtrl Ctrl, myCount, Me  '子クラスに親を教えてあげるのがミソ
    myCount = myCount + 1
End Sub

Public Sub Clear()
    Dim i As Long
    For i = 0 To myCount - 1
        Set myCtrls(i) = Nothing
    Next
    Erase myCtrls
    myCount = 0
End Sub

Private Sub Class_Terminate()
    Me.Clear
End Sub


'子クラスからイベントが通知される

Friend Sub Ctrl_Click(Ctrl As MSForms.Control, Index As Long, Container As MSForms.Control)
    Select Case TypeName(Ctrl)
        Case "CommandButton"
            RaiseEvent CmdClick(Ctrl, Index, Container)
        Case "CheckBox"
            RaiseEvent ChkClick(Ctrl, Index, Container)
        Case "OptionButton"
            RaiseEvent OptClick(Ctrl, Index, Container)
    End Select
End Sub

Friend Sub Ctrl_Change(Ctrl As MSForms.Control, Index As Long, Container As MSForms.Control)
    Select Case TypeName(Ctrl)
        Case "TextBox"
            RaiseEvent TxtChange(Ctrl, Index, Container)
    End Select
End Sub


'===== UserFormモジュール =====
'Option Explicit
'
'Private WithEvents myButtons As cCtrls
'
'Private Sub myButtons_CmdClick(ByVal Ctrl As MSForms.CommandButton, ByVal Index As Long, ByVal Container As MSForms.Control)
'    MsgBox "Caption=" & Ctrl.Caption & "  Index=" & Index & "  Name=" & Container.Name
'End Sub
'
'Private Sub UserForm_Click()
'    Dim Msg As String
'    Static C As Long
'    If myButtons.Count >= 1 And C <= myButtons.Count - 1 Then
'        With myButtons.Item(C)
'            Msg = "Caption=" & .Caption
'            Msg = Msg & vbCrLf & "Name=" & .Name
'            MsgBox Msg
'            .SetFocus
'        End With
'    End If
'    C = C + 1
'End Sub
'
'Private Sub UserForm_Initialize()
'    CreateButtons
'End Sub
'
'Private Sub UserForm_Terminate()
'    Set myButtons = Nothing
'End Sub
'
'Private Sub CreateButtons()
'    Dim myBtn As MSForms.Control
'    Const N As Long = 31
'    Const St As Long = 2
'    Dim i As Long
'    Dim L0 As Single, T0 As Single
'    Dim L As Single, T As Single, W As Single, H As Single
'    Dim Gap As Single
'
'    Set myButtons = New cCtrls
'    L0 = 10: T0 = 8: W = 28: H = 23
'    Gap = 3
'
'    For i = 1 To N
'        Set myBtn = Me.Controls.Add("Forms.CommandButton.1")
'        L = L0 + ((i - 1 + St - 1) Mod 7) * (Gap + W)
'        T = T0 + ((i - 1 + St - 1) \ 7) * (Gap + H)
'        With myBtn
'            .Left = L: .Top = T: .Width = W: .Height = H
'            .Caption = i
'        End With
'        myButtons.AddCtrl myBtn
'    Next
'End Sub


 ===== cCtrl クラスモジュール =====
Option Explicit
'Excel2000以上
'最終更新日:'11/9/16

Private myParent As cCtrls    '親クラスを保持しておくのがミソ
Private WithEvents myTxt As MSForms.TextBox
Private WithEvents myCmd As MSForms.CommandButton
Private WithEvents myChk As MSForms.CheckBox
Private WithEvents myOpt As MSForms.OptionButton
Private myIndex As Long
Private myCtrl As MSForms.Control   'Nameなどのコンテナ情報保持用

Friend Property Get Control() As MSForms.Control
    Set Control = myCtrl
End Property

Friend Sub SetCtrl(Ctrl As MSForms.Control, Index As Long, Parent As cCtrls)
    Select Case TypeName(Ctrl)
        Case "TextBox"
            Set myTxt = Ctrl
        Case "CommandButton"
            Set myCmd = Ctrl
        Case "CheckBox"
            Set myChk = Ctrl
        Case "OptionButton"
            Set myOpt = Ctrl
    End Select
    
    myIndex = Index
    Set myParent = Parent
    Set myCtrl = Ctrl
End Sub

Private Sub Class_Terminate()
    Set myParent = Nothing
    Set myTxt = Nothing
    Set myCmd = Nothing
    Set myChk = Nothing
    Set myOpt = Nothing
    Set myCtrl = Nothing
End Sub


'親クラスにイベントを返す

Private Sub myTxt_Change()
    myParent.Ctrl_Change myTxt, myIndex, myCtrl
End Sub
Private Sub myCmd_Click()
    myParent.Ctrl_Click myCmd, myIndex, myCtrl
End Sub
Private Sub myChk_Click()
    myParent.Ctrl_Click myChk, myIndex, myCtrl
End Sub
Private Sub myOpt_Click()
    If myOpt.Value Then
        myParent.Ctrl_Click myOpt, myIndex, myCtrl
    End If
End Sub


'===== TypeName =====
'CheckBox
'ComboBox
'CommandButton
'Frame
'Image
'Label
'ListBox
'MultiPage
'OptionButton
'ScrollBar
'SpinButton
'TabStrip
'TextBox
'ToggleButton
top

目盛り取り ― グラフの目盛りを適切(データ範囲+α)に設定する為の値(最小、最大、間隔)を計算する
 グラフ目盛 目盛り間隔 目盛り値 ※1998年頃に作成したプログラムなのでやや試行錯誤的な部分もあるが、実プログラム内での使用実績は充分ある。^d^
Sub test()
    Dim Minn As Double, Maxx As Double, Stepp As Double
    Dim Res As String
    
    Minn = 910: Maxx = 940
    Res = 目盛取り(Minn, Maxx, Stepp, 対数:=False, 分割数:=4, Log目盛1to9:=False)
    If Res <> "" Then
        MsgBox Res
    Else
        MsgBox Minn & ", " & Maxx & ", " & Stepp
    End If
End Sub

Private Function 目盛取り(Minn As Double, Maxx As Double, Stepp As Double, 対数 As Boolean, _
            Optional 分割数 As Integer = 6, Optional Log目盛1to9 As Boolean = False) As String
    'リニア時目盛基本分割数(デフォルト 6)
    'ログ目盛1to9   False;10^n   True;1〜9*10^n
    
    'Error ---> エラーメッセージ
    'OK ---> "", Minn, Maxx, Stepp

    Dim 分割数1 As Integer
    Dim Log目盛129 As Boolean
    Dim D1 As Double
    Dim D2 As Double
    Dim Ds As Double
    Dim S As Integer
    Dim Z As Integer
    
    分割数1 = 分割数
    
    Log目盛129 = Log目盛1to9
    
    目盛取り = ""
    
    'linear
    If 対数 = False Then
        '目盛間隔
        Ds = Maxx - Minn
        If Ds < 0 Then
            目盛取り = "自動目盛取りが出来ません。(Max < Min)"
            Exit Function
        End If
        If Ds = 0 Then
            If Minn < 0 Then
                Ds = 0 - Minn
                D1 = Minn - Ds
                D2 = 0
            ElseIf Minn = 0 Then
                Ds = 1
                D1 = -1
                D2 = 1
            Else
                Ds = Minn
                D1 = 0
                D2 = Minn + Ds
            End If
            Minn = D1
            Maxx = D2
            Stepp = Ds
            Exit Function
        End If
        Ds = Ds / 分割数1
        S = Int(Log(Ds) / Log(10) + 0.001)
        Ds = Ds / 10 ^ S
        Select Case Ds
            Case Is < 1.41
                Ds = 1
            Case Is < 3.16
                Ds = 2
            Case Is < 7.07
                Ds = 5
            Case Else
                Ds = 1
                S = S + 1
        End Select
        If S > 0 Then
            For Z = 1 To S
                Ds = Ds * 10
            Next
        ElseIf S < 0 Then
            For Z = -1 To S Step -1
                Ds = Ds / 10
            Next
        End If
        '最小目盛値
        D1 = Int(Minn / Ds + 0.001) * Ds
        If (Minn - D1) / Ds < 0.1 Then D1 = D1 - Ds
        If D1 < 0 And Minn >= 0 Then D1 = 0
        '最大目盛値
        D2 = Int(Maxx / Ds + 0.999) * Ds
        If (D2 - Maxx) / Ds < 0.1 Then D2 = D2 + Ds
    'log
    Else
        If Minn <= 0 Or Maxx <= 0 Then
            目盛取り = "対数目盛に 0 以下は適用出来ません。"
            Exit Function
        End If
        Ds = -1 'ダミー
        '最小目盛値
        S = Int(Log(Minn) / Log(10) + 0.001)
        D1 = Int(Minn / 10 ^ S + 0.001)
        If Log目盛129 = False Then D1 = 1
        If S > 0 Then
            For Z = 1 To S
                D1 = D1 * 10
            Next
        ElseIf S < 0 Then
            For Z = -1 To S Step -1
                D1 = D1 / 10
            Next
        End If
        '最大目盛値
        S = Int(Log(Maxx) / Log(10) + 0.001)
        D2 = Int(Maxx / 10 ^ S + 0.999)
        If D2 = 10 Then
            D2 = 1
            S = S + 1
        End If
        If Log目盛129 = False Then
            If D2 > 1 Then
                D2 = 1
                S = S + 1
            End If
        End If
        If S > 0 Then
            For Z = 1 To S
                D2 = D2 * 10
            Next
        ElseIf S < 0 Then
            For Z = -1 To S Step -1
                D2 = D2 / 10
            Next
        End If
    End If
        
    Minn = D1
    Maxx = D2
    Stepp = Ds
End Function
top

LoadPictureクラス ― 画像を指定セル(結合セル、セル範囲可)に読み込むクラス
 画像貼り付け 指定セルへの貼り付け 指定セルへの読み込み セルの大きさに合わせる 写真読み込み
===== 標準モジュール =====
Option Explicit

'アクティブセル(セル結合可)に一枚の画像を読み込む例
Sub Sample1()
    Dim cLP As cLoadPicture
    Dim FullPath As String

    FullPath = Application.GetOpenFilename("画像ファイル(*.jpg),*.jpg")
    If FullPath = "False" Then Exit Sub

    Set cLP = New cLoadPicture
    With cLP
        Set .LoadPointCell = ActiveCell '読み込み位置指定
        .PictureFullPath = FullPath     '画像フルパス指定
        .Margin = 2
        If .LoadPicture Then            '画像読み込み
            Debug.Print "ok"
            With .Picture
                .Placement = xlMove
                .OLEFormat.Object.PrintObject = True
                '.OnAction = "拡大縮小"  'おまけ
            End With
        Else
            Debug.Print "error"
        End If
    End With

    Set cLP = Nothing
End Sub

'複数枚の画像を連続して読み込む例
Sub Sample2()
    Dim cLP As cLoadPicture
    Dim Fs As Variant
    Dim F As Variant
    Dim R As Range
    Dim i As Long, j As Long
    Dim c As Long

    Fs = Application.GetOpenFilename("画像(*.jpg;*.jpeg),*.jpg;*.jpeg", MultiSelect:=True)
    If VarType(Fs) = vbBoolean Then Exit Sub

    Set cLP = New cLoadPicture
    Set R = Range("B2")

    For Each F In Fs
        i = c \ 4
        j = c Mod 4
        Set cLP.LoadPointCell = R.Offset(i, j)
        cLP.PictureFullPath = F
        cLP.LoadPicture
        'cLP.Picture.OnAction = "拡大縮小"   'おまけ
        c = c + 1
    Next

    Set cLP = Nothing
End Sub

'おまけ
Sub 拡大縮小()
    Dim cLP As cLoadPicture
    Dim Pic As Shape
    Dim W As Single, H As Single

    Set Pic = ActiveSheet.Shapes(Application.Caller)
    W = Pic.Width: H = Pic.Height

    Set cLP = New cLoadPicture
    With cLP
        Set .Picture = Pic
        Set .LoadPointCell = Pic.TopLeftCell
        .ResetOriginalSize
        Pic.ZOrder msoBringToFront
        If Pic.Width = W And Pic.Height = H Then
            .FitInTheCell
        End If
    End With

    Set cLP = Nothing
End Sub

===== cLoadPicture クラスモジュール =====
Option Explicit
'最終更新日:2012/2/13

Public LoadPointCell As Range
Public PictureFullPath As String
Public Margin As Single
Public SetCenter As Boolean
Private Pic As Shape

Public Property Let MarginCm(Marginn As Single)
    Margin = Application.CentimetersToPoints(Marginn)
End Property

Public Property Get Picture() As Shape
    Set Picture = Pic
End Property
Public Property Set Picture(Pct As Shape)
    Set Pic = Pct
End Property
Public Function LoadPicture() As Boolean
    Set Pic = Nothing

    If LoadPointCell Is Nothing Then Exit Function
    If PictureFullPath = "" Then Exit Function
    
    '画像の読み込み
    On Error Resume Next
    With LoadPointCell
        Set Pic = .Worksheet.Shapes.AddPicture(PictureFullPath, LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=0, Height:=0)
    End With
    On Error GoTo 0
    If Pic Is Nothing Then
        Exit Function
    End If
    
    'オリジナルサイズに復元
    ResetOriginalSize
    
    'セル内に収める
    FitInTheCell
    
    LoadPicture = True
End Function

'オリジナルサイズに復元
Public Sub ResetOriginalSize()
    If Pic Is Nothing Then Exit Sub
    Pic.ScaleWidth 1, RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromTopLeft
    Pic.ScaleHeight 1, RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromTopLeft
    Pic.Left = LoadPointCell.Left
    Pic.Top = LoadPointCell.Top
End Sub

'セル内に収める
Public Sub FitInTheCell()
    If LoadPointCell Is Nothing Then Exit Sub
    If Pic Is Nothing Then Exit Sub
    
    Dim rngTemp As Range    'セル範囲指定への対応
    Dim PastWidth As Single
    Dim PastHeight As Single
    Dim RatioW As Single
    Dim RatioH As Single
    
    '念のために
    Pic.Left = LoadPointCell.Left
    Pic.Top = LoadPointCell.Top
    
    '貼り付け先の大きさ
    If LoadPointCell.Cells.Count = 1 Then
        Set rngTemp = LoadPointCell.MergeArea
    Else
        Set rngTemp = LoadPointCell
    End If
    With rngTemp
        PastWidth = .Width - Margin * 2
        PastHeight = .Height - Margin * 2
    End With
    
    '画像と貼り付け先の大きさ比率
    RatioW = Pic.Width / PastWidth
    RatioH = Pic.Height / PastHeight
    
    '比率の大きい方を基準に縮小する(比率が1未満の時は拡大となる)
    With Pic
        .LockAspectRatio = msoTrue
        If RatioW > RatioH Then
            .Width = .Width / RatioW
        Else
            .Height = .Height / RatioH
        End If
    End With
    
    '中央に配置
    If SetCenter Then
        With Pic
            .Left = .Left + (PastWidth + Margin * 2 - .Width) / 2
            .Top = .Top + (PastHeight + Margin * 2 - .Height) / 2
        End With
    End If
    
    Set rngTemp = Nothing
End Sub

Private Sub Class_Initialize()
    Set LoadPointCell = ActiveCell
    Margin = 2
    SetCenter = True
End Sub
top

ファイル属性クラス ― GetAttr関数を使い易くクラス化
 属性取得 読み取り専用 非表示属性 ファイル存在確認
Sub Test()
    Dim cAttr As cGetAttr
    Dim myPath As String
    
    myPath = Application.GetOpenFilename("すべてのファイル(*.*),*.*", Title:="検査対象")
    If myPath = "False" Then Exit Sub
'    myPath = "C:\Documents and Settings\user\デスクトップ\test\新規テキスト ドキュメント.txt"
    
    Set cAttr = New cGetAttr
    With cAttr
        .FullPath = myPath
        Debug.Print "Exist=" & .Exist
        Debug.Print "FileName=" & .FileName
        Debug.Print "Directory=" & .Directory
        Debug.Print "ReadOnly=" & .ReadOnly
        Debug.Print "Hidden=" & .Hidden
    End With
    Set cAttr = Nothing
End Sub

'Dir関数を使用しないファイル存在確認
Private Function Dir2(FullPath As String) As String
    Dim cAttr As cGetAttr
    Set cAttr = New cGetAttr
    With cAttr
        .FullPath = FullPath
        If .Exist Then
            Dir2 = .FileName
        Else
            Dir2 = ""
        End If
    End With
    Set cAttr = Nothing
End Function

===== cGetAttr =====
Option Explicit

Private FileExist As Boolean
Private isReadOnly As Boolean
Private isHidden As Boolean
Private isSystem As Boolean
Private isDirectory As Boolean
Private isArchive As Boolean
Private FileNamee As String

Public Property Get Exist() As Boolean
    Exist = FileExist
End Property
Public Property Get ReadOnly() As Boolean
    ReadOnly = isReadOnly
End Property
Public Property Get Hidden() As Boolean
    Hidden = isHidden
End Property
Public Property Get System() As Boolean
    System = isSystem
End Property
Public Property Get Directory() As Boolean
    Directory = isDirectory
End Property
Public Property Get Archive() As Boolean
    Archive = isArchive
End Property
Public Property Get FileName() As String
    FileName = FileNamee
End Property

Public Property Let FullPath(ByVal FulPath As String)
    Dim myAttr As Integer
    Dim Fname As Variant
    
    If Right$(FulPath, 1) = "\" Then FulPath = Left$(FulPath, Len(FulPath) - 1)
    On Error GoTo Trap
    myAttr = GetAttr(FulPath)
    On Error GoTo 0
    
    If (myAttr And vbReadOnly) = vbReadOnly Then
        isReadOnly = True
    Else
        isReadOnly = False
    End If
    
    If (myAttr And vbHidden) = vbHidden Then
        isHidden = True
    Else
        isHidden = False
    End If
    
    If (myAttr And vbSystem) = vbSystem Then
        isSystem = True
    Else
        isSystem = False
    End If
    
    If (myAttr And vbDirectory) = vbDirectory Then
        isDirectory = True
    Else
        isDirectory = False
    End If
    
    If (myAttr And vbArchive) = vbArchive Then
        isArchive = True
    Else
        isArchive = False
    End If
    
    FileExist = True
    
    Fname = Split(FulPath, "\")
    Fname = Fname(UBound(Fname))
    If Fname Like "?:*" Then
        Fname = Mid$(Fname, 3)
    End If
    FileNamee = Fname
    
    Exit Property
    
Trap:
    FileExist = False
    FileNamee = ""
    Exit Property
End Property
top

テキストファイルの連結 ― フォルダ内指定パターンファイルの連結サンプル
 ファイル結合 ファイルの結合 ファイル連結 JoinFile
'テキストファイルの連結
Sub JoinTextFile()
    Const FPattern As String = "test*_#.csv" '英字は小文字で指定
    Dim Fpath As String
    Dim Fname As String
    Dim C As Integer
    Dim Fls() As String
    Dim i As Integer
    Dim cTxt As cTextFile
    Dim Txt As String
    
    Set cTxt = New cTextFile

    With cTxt
        Fpath = .DeskTopPath & "\"
        Fname = Dir(Fpath & "*.csv")
        C = 0
        Do Until Fname = ""
            If LCase(Fname) Like FPattern Then
                ReDim Preserve Fls(0 To C)
                Fls(C) = Fname
                C = C + 1
            End If
            Fname = Dir()
        Loop
        If C = 0 Then
            Set cTxt = Nothing
            MsgBox "対象ファイルがありません。", vbExclamation
            Exit Sub
        End If
        
        .WritePath = Fpath & "sum.csv"
        For i = 1 To C
            .ReadPath = Fpath & Fls(i - 1)
            Txt = .AllText
            If i >= 2 Then .Append = True
            If .EndReturn Then
                .Write0 Txt
            Else
                .Write1 Txt
            End If
        Next
    End With

    Set cTxt = Nothing
End Sub
top

テキストファイルの分割 ― テキストファイルをN行で分割し別ファイルを作成するサンプル
 テキスト分割 ファイル分割 ※テキストファイル一括読み書きクラス使用
'テキストファイルをN行で分割
Sub SplitTextFile()
    Const N As Long = 65536
    Dim cTxt As cTextFile
    Dim Txt As Variant
    Dim Txt2 As Variant
    Dim i As Long
    Dim C As Long
    Dim Fc As Long
    
    Set cTxt = New cTextFile

    With cTxt
        .ReadPath = .DeskTopPath & "\test.csv"
        Txt = .ArrayText
        C = 0
        For i = 0 To UBound(Txt)
            If C = 0 Then ReDim Txt2(0 To N - 1)
            Txt2(C) = Txt(i)
            C = C + 1
            If C = N Then
                Fc = Fc + 1
                Txt2 = Join(Txt2, .NewLineCode)
                .WritePath = .ReadPath & "_" & Fc & ".csv"
                .Write1 CStr(Txt2)
                C = 0
            ElseIf i = UBound(Txt) Then
                ReDim Preserve Txt2(0 To UBound(Txt) Mod N)
                Fc = Fc + 1
                Txt2 = Join(Txt2, .NewLineCode)
                .WritePath = .ReadPath & "_" & Fc & ".csv"
                .Write1 CStr(Txt2)
            End If
        Next
        
    End With

    Set cTxt = Nothing
End Sub
top

テキストファイル文字列置き換え ― テキストファイル中の文字列を置換えるサンプル
 ReplaceText ※テキストファイル一括読み書きクラス、正規表現クラス使用
'テキストファイル中の文字列置換え
Sub ReplaceString()
    Dim cTxt As cTextFile
    Dim cReg As cRegExp
    Dim Txt As String
    Dim Bf As String, Af As String
    Dim C As Long
    Dim Ans As Integer
    
    Set cTxt = New cTextFile
    Set cReg = New cRegExp
    
    'Bf = "([A-Za-z])\1{2}" '同じ半角英字が3文字続いていたら
    Bf = "AB"  '全角
    Af = "xyz"  '半角
    
    With cTxt
        .ReadPath = .DeskTopPath & "\test.txt"
        Txt = .AllText
        With cReg
            .Pattern = Bf
            .Globall = True
            If .ExeCute(Txt) Then
                C = .MatchesCount
                Ans = MsgBox(C & "件マッチしました。置き換えますか。", vbQuestion + vbOKCancel + vbDefaultButton2)
                If Ans = vbOK Then
                    Txt = .Replace(Txt, Af)
                Else
                    C = 0
                End If
            End If
        End With
        If C >= 1 Then
            .WritePath = .ReadPath & "_Repl.txt"    '元ファイルへ上書きなら & 以降は不要
            .Write0 Txt
        End If
    End With
    
    Set cTxt = Nothing
    Set cReg = Nothing
End Sub
top

世代バックアップ ― ファイルを指定世代までバックアップする、超えたら古い順に自動削除
 シフトバックアップ ShiftBackup ジェネレーションバックアップ AutoBackup 自動バックアップ
Option Explicit
Option Private Module

'世代バックアップ
Public Function GeneBak(ByVal TargetPath As String, Optional ByVal BakDir As String, _
    Optional MaxGeneration As Integer = 9) As String
    'TargetPathのファイルをBakDirにバックアップコピーする
    '最大MaxGeneration世代まで、名前は後ろに _番号、0番が最新、後ろは順にReNameされる
    '(途中に空き番号がある時はそれ以前の範囲でシフト)
    'BakDirの最後の\有無は問わない、BakDir省略時はファイルパス\ファイル名_bakdir
    Dim TargetName As String    'コピー元ファイル名
    Dim Ext As String           '拡張子
    Dim Dummy As String
    Dim i As Integer
    Dim NSpace As Integer       '途中の空き番号(空きが無い時は最大番号)、名前シフト範囲確定用
    Dim NN As String            'フォーマットの番号部分書式 ex. "0", "00"
    Dim OldPath As String
    Dim NewPath As String
    
    '世代最大数チェック
    If MaxGeneration < 0 Then GeneBak = "世代最大数の指定が不正です。": Exit Function
    
    '余分な空白削除
    TargetPath = Trim$(TargetPath): BakDir = Trim$(BakDir)
    
    'ファイルパス名確認
    If TargetPath = "" Then GeneBak = "ファイル指定が無効です。": Exit Function
    If TargetPath Like "*[:\\]" Then GeneBak = "ファイル指定が無効です。": Exit Function
    'ファイルパスの存在確認
    On Error Resume Next
    TargetName = Dir(TargetPath)
    On Error GoTo 0
    If TargetName = "" Then GeneBak = "ファイルが見つかりません。": Exit Function
    'ファイル名と拡張子の分離
    Ext = GetExt(TargetName)
    TargetName = Left$(TargetName, Len(TargetName) - Len(Ext))
    
    
    'バックアップ先フォルダ名
    If BakDir = "" Then BakDir = GetPath(TargetPath) & TargetName & "_bakdir"
    If Right$(BakDir, 1) <> "\" Then BakDir = BakDir & "\"  '最後の\が無ければ追加
    'バックアップ先フォルダ存在確認
    On Error Resume Next
    Dummy = Dir(BakDir, vbDirectory)
    On Error GoTo 0
    If Dummy = "" Then
        '無ければ作成
        On Error GoTo Trap
        MkDir BakDir
        On Error GoTo 0
    ElseIf (GetAttr(Dummy) And vbDirectory) <> vbDirectory Then
        '同名ファイル在り
        GeneBak = "指定フォルダと同名ファイルが存在します。"    '上で\を付加しているので実際はここは意味が無い
        Exit Function
    End If
    
    NN = String$(Len(Format$(MaxGeneration)), "0")
    
    '途中の空き番号検索
    NSpace = MaxGeneration
    For i = 0 To MaxGeneration
        OldPath = BakDir & TargetName & "_" & Format$(i, NN) & Ext
        If Dir(OldPath) = "" Then
            NSpace = i
            Exit For
        End If
    Next
    
    '既存バックアップの名前シフト
    For i = NSpace - 1 To 0 Step -1
        OldPath = BakDir & TargetName & "_" & Format$(i, NN) & Ext
        NewPath = BakDir & TargetName & "_" & Format$(i + 1, NN) & Ext
        If Dir(OldPath) <> "" Then
            '最終番号のバックアップファイルが存在する時は予め削除する
            If i = NSpace - 1 Then
                If Dir(NewPath) <> "" Then
                    Err.Clear
                    On Error Resume Next
                    Kill NewPath
                    If Err.Number <> 0 Then
                        GeneBak = "最終バックアップファイルを削除できません。"
                        On Error GoTo 0
                        Exit Function
                    End If
                    On Error GoTo 0
                End If
            End If
            
            On Error GoTo Trap
            Name OldPath As NewPath
            On Error GoTo 0
        End If
    Next
    
    'バックアップコピー(コピー先番号は「0」)
    On Error GoTo Trap
    FileCopy TargetPath, BakDir & TargetName & "_" & NN & Ext
    On Error GoTo 0
    
    GeneBak = ""
    Exit Function
    
Trap:
    GeneBak = Err.Description
    On Error GoTo 0
    Exit Function
    
End Function

'拡張子取得
Private Function GetExt(Fname As String) As String
    Dim i As Integer, j As Integer
    Do
        i = InStr(j + 1, Fname, ".")
        If i >= 1 Then j = i
    Loop Until i = 0
    
    If j = 0 Then
        GetExt = ""
    Else
        GetExt = Mid$(Fname, j)
    End If
End Function

'パス取得
'実在ファイルのフルパスを渡す。ファイル名のみの時はカレントフォルダ名を返す。
Private Function GetPath(FullPath As String) As String
    Dim myName As String
    Dim myPath As String
    
    myName = Dir(FullPath)
    
    If LCase(myName) = LCase(FullPath) Then
        myPath = CurDir
        If Right$(myPath, 1) <> "\" Then myPath = myPath & "\"
    Else
        myPath = Left$(FullPath, Len(FullPath) - Len(myName))
    End If
    
    GetPath = myPath
End Function
top

テキストファイル一括読み書きクラス ― テキストファイルの一括の読み込みと書き込みをクラス化(各種サンプル付き)
 ReadText WriteText 一括読み込み 一括書き込み ※cGetAttr(ファイル属性クラス)が必要です。
Sub Sample_Count()
    'テキストファイル中の特定文字列数をカウントする(※正規表現クラス、cRegExp使用)
    Dim cTxt As cTextFile
    Dim Txt As String
    Const Key As String = "http://"
    Dim cReg As cRegExp
    
    Set cTxt = New cTextFile
    With cTxt
        .ReadPath = .DeskTopPath & "\test.html"
        If .ErrorDescription <> "" Then
            Set cTxt = Nothing
            MsgBox .ErrorDescription, vbExclamation
            Exit Sub
        End If
        Txt = .AllText  '一気に読み込み
    End With
    Set cTxt = Nothing
    
    '正規表現クラスでカウントする
    Set cReg = New cRegExp
    With cReg
        .Pattern = Key
        .Globall = True
        .ExeCute Txt
        Debug.Print .MatchesCount
    End With
    Set cReg = Nothing
End Sub

Sub Sample_GetLine()
    'テキストファイル中のN行目を抽出する
    Dim cTxt As New cTextFile
    Dim Ary As Variant
    Dim NN As Variant
    Dim N As Variant
    
    NN = Array(1, 3, 5)
    
    Set cTxt = New cTextFile
    With cTxt
        .ReadPath = .DeskTopPath & "\test.html"
        If .ErrorDescription <> "" Then
            Set cTxt = Nothing
            MsgBox .ErrorDescription, vbExclamation
            Exit Sub
        End If
        Ary = .ArrayText    '行データを配列に取得
        For Each N In NN
            If N - 1 <= UBound(Ary) Then
                Debug.Print N; "行目 : "; Ary(N - 1); "*"
            End If
        Next
    End With
    Set cTxt = Nothing
End Sub

Sub Sample_Count2()
    'テキストファイル中の特定文字列数をカウントする、その2(正規表現を使用せずDoLoop使用)
    Dim cTxt As cTextFile
    Dim Txt As String
    Const Key As String = "http://"
    Dim T As Single
    Dim i As Long, j As Long
    Dim C As Long
    
    T = Timer
    
    Set cTxt = New cTextFile
    With cTxt
        .ReadPath = .DeskTopPath & "\test.html"
        If .ErrorDescription <> "" Then
            MsgBox .ErrorDescription, vbExclamation
            Exit Sub
        End If
        Txt = .AllText
    End With
    Set cTxt = Nothing
    
    Debug.Print Timer - T
    T = Timer
    
    i = 0: j = 0
    C = 0
    Do
        i = InStr(j + 1, Txt, Key)
        If i >= 1 Then
            C = C + 1
            j = i + Len(Key)
        End If
    Loop Until i = 0
    Debug.Print C
    
    Debug.Print Timer - T
End Sub

Sub Sample_GetString()
    'テキストファイルから特定文字列を別ファイルに抽出する(※正規表現クラス、cRegExp使用)
    '("http:// ... .jpg")
    Dim cTxt As cTextFile
    Dim cReg As cRegExp
    Dim Txt As String
    Dim i As Long
    
    Set cTxt = New cTextFile
    Set cReg = New cRegExp
    
    With cTxt
        .ReadPath = .DeskTopPath & "\Test.html"
        .WritePath = .ReadPath & "_Get.txt"
        Txt = .AllText
    End With
    
    With cReg
        .Pattern = "(http://.+\.jpg)"
        .IgnoreCase = True
        .Globall = True
        If .ExeCute(Txt) Then
            cTxt.Write1 .Value(0)
            cTxt.Append = True
            For i = 1 To .MatchesCount - 1
                cTxt.Write1 .Value(i)
            Next
        End If
    End With
    
    Set cTxt = Nothing
    Set cReg = Nothing
End Sub

===== cTextFile =====
Option Explicit

Private FullPath_Read As String     '読み込みファイルのフルパス
Private TxtAll As String            '一括で読み込んだテキスト

Private FullPath_Write As String    '書き込みファイルのフルパス
Private flgAppend As Boolean        'Falseなら上書きモード、Trueなら追加モード
Private flgSaveChanges As Boolean   '上書きモードの時、既存ファイルに上書きするかのフラグ

Private ErrorMsg As String          'エラー状態の説明(エラーがなければ"")
Private CrLf As String              '改行コード
Private flgUnicode As Boolean       'TrueならUnicode、FalseならシフトJIS
Private flgEndReturn As Boolean     '読み込んだファイルの最終改行有無フラグ

'※更新履歴
' '10/3/15 debug 別ファイル指定時の既読み込み値クリアを追加など
' '10/3/31 Dir関数を使用しないように変更し、外部のDir関数との干渉回避
'      ⇒★★★★★ cGetAttrクラスを使用 ★★★★★

'●cTextFileクラスの機能
'1.テキストファイルの改行コードを含む一括読み込み
'2.テキストファイルを行毎に分割して配列に読み込み
'3.改行コードを任意に指定可能
'4.上書きモードまたは追加モードでテキストファイルへ書き込み
'5.書き込み時、最後に改行コードを付けるか付けないかを選択可
'6.シフトJISに加えて、Unicodeテキストも自動認識
'7.デスクトップパスとマイドキュメントパス取得のおまけ付き
'8.二次元配列から指定の一列を取得する関数(メソッド)のおまけ付き
'
'●プロパティとメソッド
'NewLineCodeプロパティ: 読み込み時の改行コードを指定します。初期値はvbCrLf。設定と取得が可能です。String型を使用します。
'ErrorDescriptionプロパティ: プロパティ設定やメソッド実行時のエラーメッセージを保持します。取得のみ可能です。String型を使用します。
'Unicodeプロパティ: TrueがUnicode、FalseがシフトJISです。ファイルを読み込むと自動で再設定されます。初期値はFalse、設定と取得が可能です。Boolean型を使用します。
'EndReturnプロパティ: ファイルの最終に改行コードが在ったかどうかを示します。ArrayTextプロパティで読み込んだ時、最終の改行が在ったか無かったかが分からないため、その確認の為のプロパティです。Boolean型を使用します。
'DeskTopPathプロパティ: 現在使用中のデスクトップのパスです。取得のみ可能です。String型を使用します。
'MyDocumentPathプロパティ: 現在使用中のマイドキュメントのパスです。取得のみ可能です。String型を使用します。
'GetColmnFromArrayメソッド:二次元配列から指定列を一次元配列(Index0から)として取り出します。forCell:=Trueとすることで、N行1列の二次元配列での取得も可能です。これはその値をそのままワークシート上に縦に貼り付ける時に便利な機能です。なお、配列以外を引数として渡しても、要素が1個の配列を返します。
'
'ReadPathプロパティ:読み込み用テキストファイルのフルパスです。設定と取得が可能です。String型を使用します。設定時、指定ファイルが見つからない場合はErrorDescriptionにその旨が設定されます。見つかった場合にはErrorDescriptionのそれまでの値はクリア("")されます。
'ReadFileNameプロパティ:ReadPathプロパティのファイル名のみの部分(最後の「\」の後ろ)を返します。取得のみ可能です。String型を使用します。
'ReadAllメソッド:ファイルの内容を改行を含めてすべて読み込み、成功したか否かの結果を返します。Boolean型を使用します。失敗した場合はErrorDescriptionにその旨が設定されます。なお、読み込んだ結果はAllTextまたはArrayTextプロパティで取得します。シフトJISかUnicodeかは自動判別し、その結果はUnicodeプロパティに保持されます。
'AllTextプロパティ: 現在保持している読み込んだテキストを返します。まだ読み込んでいない場合は内部でReadAllメソッドが実行されます。取得のみ可能です。String型を使用します。
'ArrayTextプロパティ:現在保持している読み込んだテキストを、行毎に分割して配列で返します。まだ読み込んでいない場合は内部でReadAllメソッドが実行されます。取得のみ可能です。Variant型を使用します。なお、最終の改行が在っても空の要素は付加されません。このプロパティは実行の都度、あらためて行の分割が行なわれます(分割した結果はクラス内に保持されません)。大きなテキストの場合は注意してください。
'
'Appendプロパティ: Trueで追加モード、Falseで上書きモードの指定です。初期値はFalseです。設定のみ可能です。Boolean型を使用します。
'SaveChangesプロパティ:上書きモード(Append=False)の時、既存ファイルに対して強制的に上書きするかのフラグ。初期値はTrue。設定のみ可能です。Boolean型を使用します。既存ファイルがあった時に上書きしたくない時にFalseに設定します。
'WritePathプロパティ:書き込み用テキストファイルのフルパスです。設定と取得が可能です。String型を使用します。設定時、ファイル既存&上書きモード&上書き指定でない場合はErrorDescriptionにその旨("指定ファイルが既に存在します。")が設定されます。そうでない場合にはErrorDescriptionのそれまでの値はクリア("")されます。
'WriteFileNameプロパティ:WritePathプロパティのファイル名のみの部分(最後の「\」の後ろ)を返します。取得のみ可能です。String型を使用します。
'Write1メソッド: 引数の変数の内容をテキストファイルに書き込みます。最後に改行も追加で書き込み、成功したか否かの結果を返します。Boolean型を使用します。失敗した場合はErrorDescriptionにその旨が設定されます。
'Write0メソッド: 引数の変数の内容をテキストファイルに書き込みます。改行の追加書き込みはしません。成功したか否かの結果を返します。Boolean型を使用します。失敗した場合はErrorDescriptionにその旨が設定されます。
'
'●注意事項
'WritePathプロパティの設定は、AppendプロパティとSaveChangesプロパティを設定してから行なってください。但し、上書きモード(Append=False)で強制上書き(SaveChanges=True)の時はその値が初期値なので特に設定の必要はありません。
'既存ファイルの上書きに失敗すると、「元ファイル名.bak」という名前のファイルが残る場合があります。

Private Sub Class_Initialize()
    ErrorMsg = ""
    CrLf = vbCrLf
    flgUnicode = False
    
    flgAppend = False
    flgSaveChanges = True
End Sub

Private Sub Class_Terminate()
    TxtAll = ""
End Sub

'改行コード
Public Property Let NewLineCode(NewLnCode As String)
    If NewLnCode <> "" Then
        CrLf = NewLnCode
    End If
End Property
Public Property Get NewLineCode() As String
    NewLineCode = CrLf
End Property

'エラー状態の説明(エラーがなければ"")
Public Property Get ErrorDescription() As String
    ErrorDescription = ErrorMsg
End Property

'Unicodeフラグ
Public Property Let Unicode(UniCD As Boolean)
    flgUnicode = UniCD
End Property
Public Property Get Unicode() As Boolean
    Unicode = flgUnicode
End Property

'読み込んだファイルの最終改行有無フラグ
Public Property Get EndReturn() As Boolean
    EndReturn = flgEndReturn
End Property

'デスクトップのパス(おまけ)
Public Property Get DeskTopPath() As String
    DeskTopPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop")
End Property

'マイドキュメントのパス(おまけ)
Public Property Get MyDocumentPath() As String
    MyDocumentPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")
End Property

'二次元配列から指定列を一次元配列(Index0から)として取り出す(おまけ)
Public Function GetColumnFromArray(Ary As Variant, ByVal Column As Long, _
    Optional forCell As Boolean) As Variant
    Dim V As Variant
    Dim i As Long
    Dim C As Long
    
    If Right$(TypeName(Ary), 2) <> "()" Then
        If forCell Then
            ReDim V(0 To 0, 0 To 0)
            V(0, 0) = Ary
            GetColumnFromArray = V
        Else
            GetColumnFromArray = Array(Ary)
        End If
        Exit Function
    End If
    
    If forCell Then
        ReDim V(0 To UBound(Ary) - LBound(Ary), 0 To 0)
    Else
        ReDim V(0 To UBound(Ary) - LBound(Ary))
    End If
    
    If Column < LBound(Ary, 2) Then Column = LBound(Ary, 2)
    If Column > UBound(Ary, 2) Then Column = UBound(Ary, 2)
    
    C = 0
    If forCell Then
        For i = LBound(Ary) To UBound(Ary)
            V(C, 0) = Ary(i, Column)
            C = C + 1
        Next
    Else
        For i = LBound(Ary) To UBound(Ary)
            V(C) = Ary(i, Column)
            C = C + 1
        Next
    End If
    
    GetColumnFromArray = V
End Function


'*************** 読み込み ***************

'読み込みテキストファイルのフルパス
Public Property Let ReadPath(FullName As String)
    Dim Fname As String
    
    On Error GoTo Trap
    Fname = Dir2(FullName)
    On Error GoTo 0
    
    If Fname = "" Then
        ErrorMsg = "指定ファイルが見つかりません。"
        FullPath_Read = ""
        TxtAll = ""
    Else
        ErrorMsg = ""
        If FullName <> FullPath_Read Then
            TxtAll = "" '別ファイル指定時は既読み込み値クリア
        End If
        FullPath_Read = FullName
    End If
    Exit Property
    
Trap:
    ErrorMsg = Err.Description
    FullPath_Read = ""
    On Error GoTo 0
    
End Property
Public Property Get ReadPath() As String
    ReadPath = FullPath_Read
End Property

'読み込みのファイル名のみの取得
Public Property Get ReadFileName() As String
    Dim V As Variant
    If FullPath_Read = "" Then
        ReadFileName = ""
    Else
        V = Split(FullPath_Read, "\")
        ReadFileName = V(UBound(V))
    End If
End Property

'すべて読み込み(成功:True、失敗:False)
Public Function ReadAll() As Boolean
    Dim N As Integer
    Dim bTxt() As Byte
    
    If ErrorMsg <> "" Then
        ReadAll = False
        Exit Function
    End If
    
    If FullPath_Read = "" Then
        ErrorMsg = "読み込みファイルの指定がありません。"
        ReadAll = False
        Exit Function
    End If
    
    N = FreeFile
    On Error GoTo Trap
    
    Open FullPath_Read For Binary Access Read Lock Write As #N
    ReDim bTxt(1 To LOF(N))
    Get #N, 1, bTxt()
    TxtAll = CStr(bTxt)
    
    If bTxt(1) = 255 And bTxt(2) = 254 Then
        'Unicode
        flgUnicode = True
    Else
        'シフトJIS
        flgUnicode = False
    End If
    Erase bTxt
    
    If flgUnicode Then
        TxtAll = MidB$(TxtAll, 3)
    Else
        TxtAll = StrConv(TxtAll, vbUnicode)
    End If
    Close #N
    
    If Right$(TxtAll, Len(CrLf)) = CrLf Then
        flgEndReturn = True
    Else
        flgEndReturn = False
    End If

    On Error GoTo 0
    ErrorMsg = ""
    ReadAll = True
    Exit Function
    
Trap:
    ErrorMsg = Err.Description
    Close #N
    On Error GoTo 0
    ReadAll = False
    Exit Function
    
End Function

'一変数に読み込んで取得(.ReadAll省略可)
Public Property Get AllText() As String
    If TxtAll = "" Then ReadAll
    If ErrorMsg <> "" Then
        AllText = ErrorMsg
        Exit Property
    End If
    AllText = TxtAll
End Property

'読み込んだテキストを配列に分割して取得(.ReadAll省略可)
Public Property Get ArrayText() As Variant
    Dim VV As Variant
    
    If TxtAll = "" Then ReadAll
    If ErrorMsg <> "" Then
        ArrayText = Array(ErrorMsg)
        Exit Property
    End If
    
    VV = Split(TxtAll, CrLf)
    If flgEndReturn Then
        ReDim Preserve VV(LBound(VV) To UBound(VV) - 1)
    End If
    
    ArrayText = VV
    
    Erase VV
End Property


'*************** 書き込み ***************

'追加書き込みモード指定
Public Property Let Append(AppendMode As Boolean)
    flgAppend = AppendMode
End Property

'上書きフラグ(上書きモード(flgAppend=False)の時、既存ファイルに対して強制的に上書きするかのフラグ)
Public Property Let SaveChanges(SaveChange As Boolean)
    flgSaveChanges = SaveChange
End Property

'書き込みテキストファイルのフルパス
Public Property Let WritePath(FullName As String)
    Dim Fname As String
    
    On Error GoTo Trap
    Fname = Dir2(FullName)
    On Error GoTo 0
    
    If Fname <> "" And flgAppend = False And flgSaveChanges = False Then
        'ファイル既存&上書きモード&上書き指定でないなら
        ErrorMsg = "指定ファイルが既に存在します。"
        FullPath_Write = ""
    Else
        ErrorMsg = ""
        FullPath_Write = FullName
    End If
    Exit Property
    
Trap:
    ErrorMsg = Err.Description
    FullPath_Write = ""
    On Error GoTo 0
    
End Property
Public Property Get WritePath() As String
    WritePath = FullPath_Write
End Property

'書き込みのファイル名のみ
Public Property Get WriteFileName() As String
    Dim V As Variant
    If FullPath_Write = "" Then
        WriteFileName = ""
    Else
        V = Split(FullPath_Write, "\")
        WriteFileName = V(UBound(V))
    End If
End Property

'書き込み(最終改行有り)
Public Function Write1(Txt As String) As Boolean
    Write1 = WriteSub(Txt, True)
End Function

'書き込み(最終改行無し)
Public Function Write0(Txt As String) As Boolean
    Write0 = WriteSub(Txt, False)
End Function

'書き込みサブ(成功:True、失敗:False)
Private Function WriteSub(Txt As String, EndRet As Boolean) As Boolean
    Dim N As Integer
    Dim Bt(1 To 2) As Byte
    Dim bTxt() As Byte
    Dim i As Long
    Dim bakPath As String   '書き込み失敗時の保険用ファイルパス
    
    If ErrorMsg <> "" Then
        WriteSub = False
        Exit Function
    End If
    
    If FullPath_Write = "" Then
        ErrorMsg = "書き込みファイルの指定がありません。"
        WriteSub = False
        Exit Function
    End If
    
    On Error GoTo Trap
    
    'ファイルが既存で上書きモード(追加モードでなく)で上書き指定の時は _
     一旦既存ファイルをリネームしておく
    If Dir2(FullPath_Write) <> "" Then
        If flgAppend Then
            'nop
        ElseIf flgSaveChanges = True Then   'Falseは上で除外しているからここはTrueしか有りあえないが、コード変更時の保険
            'Kill FullPath_Write
            bakPath = FileBackup(FullPath_Write)    '一旦リネームしてとっておく
        Else
            ErrorMsg = "既存ファイルに上書きは出来ません。" '同上で保険
            WriteSub = False
            On Error GoTo 0
            Exit Function
        End If
    End If
    
    N = FreeFile
    Open FullPath_Write For Binary Access Write Lock Read Write As #N
    
    'Unicodeの印
    If flgUnicode Then
        '上書きモードまたは追加モードでもファイルが新規の時
        If LOF(N) = 0 Then
            Bt(1) = 255: Bt(2) = 254
            Put #N, 1, Bt()
        End If
    End If
    
    '書き込み位置は最後+1バイト目
    If flgUnicode Then
        ReDim bTxt(1 To LenB(Txt))
        bTxt = Txt
        Put #N, LOF(N) + 1, bTxt
        Erase bTxt
    Else
        Put #N, LOF(N) + 1, Txt
    End If
    
    '最終改行
    If EndRet Then
        If flgUnicode Then
            ReDim bTxt(1 To LenB(CrLf))
            bTxt = CrLf
            Put #N, LOF(N) + 1, bTxt
            Erase bTxt
        Else
            Put #N, LOF(N) + 1, CrLf
        End If
    End If
    
    Close #N
    
    If bakPath <> "" Then Kill bakPath  '念のためのバックアップ元ファイルを削除
    
    On Error GoTo 0
    ErrorMsg = ""
    WriteSub = True
    Exit Function
    
Trap:
    ErrorMsg = Err.Description
    Close #N
    On Error GoTo 0
    WriteSub = False
    Exit Function
    
End Function

'.bakとファイル名を変更し、そのファイル名を返す
Private Function FileBackup(FullPath As String) As String
    Dim Fpath As String
    Dim Dummy As String
    
    Fpath = FullPath
    Do
        Fpath = Fpath & ".bak"
        Dummy = Dir2(Fpath)
    Loop Until Dummy = ""
    
    Name FullPath As Fpath
    FileBackup = Fpath
End Function

'Dir関数を使用しないファイル存在確認
Private Function Dir2(FullPath As String) As String
    Dim cAttr As cGetAttr
    Set cAttr = New cGetAttr
    With cAttr
        .FullPath = FullPath
        If .Exist Then
            Dir2 = .FileName
        Else
            Dir2 = ""
        End If
    End With
    Set cAttr = Nothing
End Function



'Sub Test1() '単純に全体を読み込み
'    Dim cTxt As cTextFile
'
'    Set cTxt = New cTextFile
'
'    With cTxt
'        .ReadPath = .DeskTopPath & "\Sample.log"
'        If .ReadAll Then
'            Debug.Print .AllText
'        Else
'            Debug.Print .ErrorDescription
'        End If
'    End With
'
'    Set cTxt = Nothing
'End Sub
'
'Sub Test2() '各行を配列に読み込み
'    Dim cTxt As cTextFile
'    Dim VV As Variant
'    Dim i As Long
'
'    Set cTxt = New cTextFile
'
'    With cTxt
'        .ReadPath = .DeskTopPath & "\Sample2.log"
'        If .ErrorDescription <> "" Then
'            Debug.Print .ErrorDescription
'        Else
'            VV = .ArrayText
'            For i = 0 To UBound(VV)
'                Debug.Print "*"; VV(i); "*"
'            Next
'        End If
'    End With
'
'    Set cTxt = Nothing
'End Sub
'
'Sub Test3() '変数の内容を単純に書き込み
'    Dim cTxt As cTextFile
'    Dim Txt As String
'
'    Set cTxt = New cTextFile
'    Txt = "テスト3"
'
'    With cTxt
'        .WritePath = .DeskTopPath & "\Test3.txt"
'        If .Write1(Txt) Then
'            Debug.Print "ok"
'        Else
'            Debug.Print .ErrorDescription
'        End If
'    End With
'
'    Set cTxt = Nothing
'End Sub
'
'Sub Test4() '色々な書き込み
'    Dim cTxt As cTextFile
'
'    Set cTxt = New cTextFile
'
'    With cTxt
'        .SaveChanges = False    '既存ファイルへの上書き禁止(但し追加は除く)
''        .Append = True          '追加書き込みの指定
''        .Unicode = True         'Unicodeの指定
'        '(シフトJISファイルにUnicodeで追加などというような無茶な指定はしないように^^;)
'        '(もし、Appendモード時に自動でUnicode判別したければ、一旦ダミーでそのファイルを読み込めば良い。)
'        .WritePath = .DeskTopPath & "\Test4.txt"
'        If .ErrorDescription <> "" Then
'            Debug.Print .ErrorDescription
'        Else
'            If .Write0("テスト4") Then '改行無し
'                Debug.Print "ok"
'            Else
'                Debug.Print .ErrorDescription
'            End If
'        End If
'    End With
'
'    Set cTxt = Nothing
'End Sub
'
'Sub Test5() '読み込んだファイルの最初と最後の行を別ファイルに出力
'    Dim cTxt As cTextFile
'    Dim VV As Variant
'
'    Set cTxt = New cTextFile
'
'    With cTxt
'        .ReadPath = .DeskTopPath & "\Sample2.log"
'        VV = .ArrayText
'        .WritePath = .ReadPath & "_2.txt"
'        .Write1 CStr(VV(LBound(VV)))
'        .Append = True
'        .Write1 CStr(VV(UBound(VV)))
'    End With
'
'    Set cTxt = Nothing
'End Sub
top

ワークシートN枚の新規ブック作成 ― 指定枚数ちょうどのワークシートを持つ新規ブックを作成して返す
 N枚のワークシート シート一枚のブック作成 ワークシート数指定
'ワークシートN枚のブックを新規に作成して返す
Public Function CreateWb(N As Integer) As Workbook
    Dim Cbak As Long
    Cbak = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = N
    Set CreateWb = Workbooks.Add
    Application.SheetsInNewWorkbook = Cbak
End Function
top

正規表現クラス ― RegExpオブジェクトをクラス化して少々使い易く?したもの
 ※使用例、Helpからのパターン文字説明の抜粋付き
===== cRegExp =====
Option Explicit

Private RegEx As Object
Private Matches As Object
Private strValue As String  'LeftValue, RightValue用

Public Property Let Pattern(Ptn As String)
    RegEx.Pattern = Ptn
End Property

Public Property Let Globall(Glb As Boolean)
    RegEx.Global = Glb
End Property

Public Property Let IgnoreCase(IgCase As Boolean)
    RegEx.IgnoreCase = IgCase
End Property

Public Property Let MultiLine(MultiLin As Boolean)
    RegEx.MultiLine = MultiLin
End Property


Public Function ExeCute(Stringg As String) As Boolean
    ExeCute = RegEx.Test(Stringg)
    Set Matches = RegEx.ExeCute(Stringg)
    
    strValue = Stringg
End Function

Public Function Test(Stringg As String) As Boolean
    Test = RegEx.Test(Stringg)
End Function

Public Function Replace(String1 As String, String2 As String) As String
    Replace = RegEx.Replace(String1, String2)
End Function


Public Property Get MatchesCount() As Long
    If Not Matches Is Nothing Then
        MatchesCount = Matches.Count
    End If
End Property

Public Property Get SubMatchesCount() As Long
'リマーク内記述は、ExeCute無しでパターン指定のみからサブマッチ数を返すもの
'    Dim myRegExp As cRegExp
'    Dim myStr As String
'
'    myStr = RegEx.Pattern
'
'    Set myRegExp = New cRegExp
'    With myRegExp
'        .Pattern = "\([^\?][^()]+\)"
'        .Globall = True
'        .IgnoreCase = False
'        .ExeCute myStr
'        SubMatchesCount = .MatchesCount
'    End With
'    Set myRegExp = Nothing
    If Not Matches Is Nothing Then
        SubMatchesCount = Matches(0).SubMatches.Count
    End If
End Property


'各Indexは0から
Public Property Get FirstIndex(Optional MatchIndex As Long) As Long
    FirstIndex = Matches(MatchIndex).FirstIndex
End Property

Public Property Get Length(Optional MatchIndex As Long) As Long
    Length = Matches(MatchIndex).Length
End Property

Public Property Get Value(Optional MatchIndex As Long) As String
    Value = Matches(MatchIndex).Value
End Property

Public Property Get SubMatchesValue(Optional MatchIndex As Long, _
        Optional SubMatchIndex As Long) As String
    SubMatchesValue = Matches(MatchIndex).SubMatches(SubMatchIndex)
End Property

Public Property Get LeftValue(Optional MatchIndex As Long) As String
    Dim i As Long
    
    i = Matches(MatchIndex).FirstIndex
    
    LeftValue = VBA.Left$(strValue, i)
End Property

Public Property Get RightValue(Optional MatchIndex As Long) As String
    Dim i As Long
    Dim L As Long
    
    With Matches(MatchIndex)
        i = .FirstIndex
        L = .Length
    End With
    
    RightValue = VBA.Mid$(strValue, i + L + 1)
End Property


Private Sub Class_Initialize()
    Set RegEx = CreateObject("VBScript.RegExp")
    Set Matches = Nothing
    Globall = False     '最初の一致だけを検索
    IgnoreCase = False  '大文字と小文字を区別する
End Sub

Private Sub Class_Terminate()
    Set RegEx = Nothing
    Set Matches = Nothing
End Sub


'Sub RegExpTest()   '一般例
'    Dim myRegExp As cRegExp
'    Dim myStr As String
'    Dim i As Long
'
'    myStr = "1aa2a34aaa5"
'
'    Set myRegExp = New cRegExp
'    With myRegExp
'        .Pattern = "\d\D\d"
'        .Globall = False
'        .IgnoreCase = False
'        If .ExeCute(myStr) Then     'マッチ有無の確認だけなら.Testが良い
'            Debug.Print .Value      '"2a3"
'            Debug.Print .FirstIndex '3     (オフセット)
'            Debug.Print .Length     '3
'            Debug.Print .LeftValue  '"1aa"
'            Debug.Print .RightValue '"4aaa5"
'        End If
'    End With
'    Set myRegExp = Nothing
'End Sub
'
'Sub RegExpTest2()  '全て検索
'    Dim myRegExp As cRegExp
'    Dim myStr As String
'    Dim i As Long
'
'    myStr = "1aa2a34aaa5"
'
'    Set myRegExp = New cRegExp
'    With myRegExp
'        .Pattern = "\d+"
'        .Globall = True    '全て検索
'        .IgnoreCase = False
'        .ExeCute myStr
'        For i = 0 To .MatchesCount - 1
'            Debug.Print .Value(i)   '1, 2, 34, 5
'        Next
'    End With
'    Set myRegExp = Nothing
'End Sub
'
'Sub ReplaceTest()  'すべて置換え
'    Dim myRegExp As cRegExp
'    Dim myStr As String
'
'    myStr = "1aa2a34aaa5"
'
'    Set myRegExp = New cRegExp
'    With myRegExp
'        .Pattern = "\d+"
'        .Globall = True
'        .IgnoreCase = False
'        myStr = .Replace(myStr, "0")
'    End With
'    Set myRegExp = Nothing
'
'    Debug.Print myStr   '0aa0a0aaa0
'End Sub
'
'Sub ReplaceTest2() 'サブマッチを使い置換え
'    Dim myRegExp As cRegExp
'    Dim myStr As String
'
'    myStr = "The quick brown fox jumped over the lazy dog."
'
'    Set myRegExp = New cRegExp
'    With myRegExp
'        .Pattern = "(\S+)(\s+)(\S+)"
'        .Globall = True
'        .IgnoreCase = False
'        myStr = .Replace(myStr, "$3$2$1")
'    End With
'    Set myRegExp = Nothing
'
'    Debug.Print myStr   'quick The fox brown over jumped lazy the dog.
'End Sub
'
'Sub 後方参照Test()
'    Dim myRegExp As cRegExp
'    Dim myStr As String
'
'    myStr = "Is is the cost of of gasoline going up up?."
'
'    Set myRegExp = New cRegExp
'    With myRegExp
'        .Pattern = "\b([a-z]+) \1\b"  '\1が1つ目のサブマッチ([a-z]+)にマッチした【内容】と同一
'        .Globall = True
'        .IgnoreCase = True
'        myStr = .Replace(myStr, "$1")
'    End With
'    Set myRegExp = Nothing
'
'    Debug.Print myStr   'Is the cost of gasoline going up?.
'End Sub
'
'Sub 後方参照Test2()
'    Dim myRegExp As cRegExp
'    Dim myStr As String
'
'    myStr = "aaa123-abcd-9876-123-456"
'
'    Set myRegExp = New cRegExp
'    With myRegExp
'        .Pattern = "(\d{3}).+\1"    '\1が1つ目のサブマッチにマッチした【内容】と同一
'        .Globall = True
'        .IgnoreCase = True
'        If .ExeCute(myStr) Then
'            Debug.Print .Value(0)   '123-abcd-9876-123
'        Else
'            Debug.Print "NoMatch"
'        End If
'    End With
'    Set myRegExp = Nothing
'End Sub
'
'Sub SubMatchTest() 'サブマッチの値を使用(使用時はマッチ数、サブマッチ数に注意)
'    Dim myRegExp As cRegExp
'    Dim myStr As String
'
'    myStr = "1aa2a34aaa5"
'
'    Set myRegExp = New cRegExp
'    With myRegExp
'        .Pattern = "(\d)\D+(\d)"
'        .Globall = True
'        .IgnoreCase = False
'        .ExeCute myStr
'        Debug.Print .SubMatchesValue(0, 0)  '"1"  ("1aa2"の"1")
'        Debug.Print .SubMatchesValue(1, 1)  '"5"  ("4aaa5"の"5")
'    End With
'    Set myRegExp = Nothing
'End Sub
'
'Sub 肯定先読みTest()
'    Dim myRegExp As cRegExp
'    Dim myStr1 As String
'    Dim myStr2 As String
'    Dim i As Long
'
'    myStr1 = "Windows NT Win 2000"
'    myStr2 = "Windows 3.1"
'
'    Set myRegExp = New cRegExp
'    With myRegExp
'        .Pattern = "(Windows|Win) (?=95|98|NT|2000)"  '肯定先読み(?=)
'        .Globall = True
'        .IgnoreCase = False
'
'        If .ExeCute(myStr1) Then
'            For i = 0 To .MatchesCount - 1
'                Debug.Print .Value(i)   '"Windows", "Win"
'            Next
'        Else
'            Debug.Print "NoMatch"
'        End If
'
'        If .ExeCute(myStr2) Then
'            Debug.Print .Value(0)
'        Else
'            Debug.Print "NoMatch"   'こちら
'        End If
'    End With
'    Set myRegExp = Nothing
'End Sub
'
'Sub 肯定先読みTest2()
'    Dim myRegExp As cRegExp
'    Dim myStr As String
'    Dim i As Long
'
'    myStr = "1-3abc-d57"
'
'    Set myRegExp = New cRegExp
'    With myRegExp
'        .Pattern = "\d(?=.+\d\d)"  '肯定先読み
'        .Globall = True
'        .IgnoreCase = False
'
'        If .ExeCute(myStr) Then
'            For i = 0 To .MatchesCount - 1
'                Debug.Print .Value(i)  '"1-3abc-d57"から"1"、"3abc-d57"から"3"
'            Next
'        Else
'            Debug.Print "NoMatch"
'        End If
'    End With
'    Set myRegExp = Nothing
'End Sub



'パターン文字とその内容

'文字   内容
'\      次に続く文字が特別な文字またはリテラルであることを示します。たとえば、"n" は "n" _
        という文字と一致します。"\n"は、改行文字と一致します。"\\" は、"\" と一致します。 _
        "\(" は "(" と一致します。
        
'^      入力の開始と一致します。

'$      入力の終端と一致します。

'*      直前の文字と 0 回以上一致します。たとえば、"zo*" は "z" とも "zoo" とも一致します。

'+      直前の文字と 1 回以上一致します。たとえば、"zo+" は "zoo" とは一致しますが、"z" _
        とは一致しません。

'?      直前の文字と; 0; 回または; 1; 回一致します。たとえば、; "a?ve?"; は; "never"; の; _
        "ve"; に一致します。

'.      改行文字以外の任意の単独文字と一致します。

'(pattern) 引数 pattern に指定した文字と一致します。一致する文字列が見つかったら、記憶さ _
        れます。一致した部分は、Matches コレクションの項目 [0]...[n] から取得できます。 _
        かっこ文字、() を指定するには、"\(" および "\)" を使用します。※最下行も参照のこと

'x|y    x と y のどちらかと一致します。たとえば、"z|wood" は "z" と "wood" に一致します。 _
        "(z|w)oo" は、"zoo" と "wood" に一致します。

'{n}    n には、0 以上の整数を指定します。直前の文字と正確に n 回一致します。たとえば、 _
        "o{2}" は、"Bob" の "o" とは一致しませんが、"foooood" の最初の 2 つの o とは一致 _
        します。

'{n,}   n には、0 以上の整数を指定します。直前の文字と少なくとも n 回一致します。 _
        たとえば、"o{2,}" は、"Bob" の "o" とは一致しませんが、"foooood" のすべての o _
        と一致します。"o{1,}" は、"o+" と同じ意味になります。"o{0,}" は、"o*" と同じ意味 _
        になります。

'{n,m}  m および n には、0 以上の整数を指定します。直前の文字と n 〜 m 回一致します。 _
        たとえば、"o{1,3}" は、"fooooood" の最初の 3 つの o と一致します。"o{0,1}" は、 _
        "o?" と同じ意味になります。

'[xyz]  文字セット。角かっこで囲まれた文字の中のいずれかと一致します。たとえば、"[abc]" _
        は "plain" の "a" と一致します。
        
'[^xyz] 否定の文字セット。角かっこで囲まれた文字にはない任意の文字と一致します。"[^abc]" _
        は、"plain" の "p" と一致します。
        
'[a-z]  文字の範囲。指定した範囲に含まれる任意の文字に一致します。たとえば、"[a-z]" は、 _
        "a" から "z" までの任意のアルファベットの小文字に一致します。
        
'[^m-z] 否定の文字の範囲。指定した範囲に含まれていない任意の文字に一致します。たとえば、 _
        "[^m-z]" は "m" から "z" までの範囲に含まれない任意の文字に一致します。
        
'\b     単語の境界と一致します。単語の境界とは、単語とスペースの間の位置のことです。 _
        たとえば、"er\b" は、"never" の "er" に一致します。"verb" の "er" には一致しません。

'\B     単語の境界ではない部分と一致します。たとえば、"ea*r\B" は、"never early" の _
        "ear" と一致します。
        
'\d     数字と一致します。[0-9] と指定した場合と同じ意味になります。

'\D     数字以外の文字と一致します。[^0-9] と指定した場合と同じ意味になります。

'\f     フォームフィード文字と一致します。

'\n     改行文字と一致します。

'\r     キャリッジ リターン文字と一致します。

'\s     スペース、タブ、フォームフィードなどの任意の空白文字と一致します。 _
        "[ \f\n\r\t\v]" と指定した場合と同じ意味になります。
        
'\S     空白文字のない部分と一致します。"[^ \f\n\r\t\v]" と指定した場合と同じ意味になります。

'\t     タブ文字と一致します。

'\v     垂直タブ文字と一致します。

'\w     単語に使用される任意の文字と一致します。これには、アンダースコアも含まれます。 _
        "[A-Za-z0-9_]" と指定した場合と同じ意味になります。
        
'\W     単語に使用される文字以外の任意の文字と一致します。"[^A-Za-z0-9_]" と指定した場合 _
        と同じ意味になります。
        
'\num   num には、正の整数を指定します。既に見つかり、記憶されている部分と一致します。 _
        たとえば、"(.)\1" は、連続する 2 つの同じ文字に一致します。
        
'\n     n に指定した 8 進数のエスケープ値と一致します。8 進数の値には、1 桁、2 桁、または _
        3 桁で指定します。たとえば、"\11" と "\011" は、両方ともタブ文字に一致します。 _
        "\0011" は、"\001" および "1" と同じ意味になります。8 進数のエスケープ値は、256 _
        を超えることはできません。256 を超える数値を指定した場合、初めの 2 桁で値が評価 _
        されます。この表記により、正規表現で ASCII コードを使用できるようになります。
        
'\xn    n に指定した 16 進数のエスケープ値と一致します。16 進数のエスケープ値は、2 桁で _
        ある必要があります。たとえば、"\x41" は、"A" に一致します。"\x041" は、"\x04" _
        および "1"と同じ意味になります。この表記により、正規表現で ASCII コードを使用でき _
        るようになります。


'以下、正規表現の構文より追加

'\num   num に一致します。ここで num は正の整数です。記憶された一致文字列への後方参照です。 _
        たとえば、'(.)\1' は 2 つの連続した同一文字に一致します。

'\n     8 進エスケープ値または後方参照のいずれかを表します。\n の前に保存されたサブ式が _
        少なくとも n 個存在する場合、n は後方参照を表します。 _
        それ以外の場合で n が 8 進数 (0 〜 7) である場合、n は 8 進エスケープ値を表します。

'\nm    8 進エスケープ値または後方参照のいずれかを表します。\nm の前に保存されたサブ式が _
        少なくとも nm 個存在する場合、\nm は後方参照を表します。\nm の前に保存された _
        サブ式が少なくとも n 個存在する場合、後方参照 n の後にリテラル m が続いていること _
        を表します。 _
        それ以外の場合で n と m が 8 進数 (0 〜 7) である場合、\nm は 8 進エスケープ値 _
        nm に一致します。

'\nml   n が 8 進数 (0 〜 3) で m と l が 8 進数 (0 〜 7) である場合、8 進エスケープ値 _
        nml に一致します。

'\un    n に一致します。n は、4 桁の 16 進数として表現された Unicode 文字を表します。 _
        たとえば、'\u00A9' は著作権記号 (c) に一致します。

'(?:pattern) pattern に一致しますが、一致文字列は【記憶しません】(後では使用不可)。 _
        この構文は、"or" 文字 (|) を使ってパターンの各部分を結合する場合に便利です。 _
        たとえば、  'industr(?:y|ies)' は 'industry|industries' よりも効率的な正規表現です。

'(?=pattern) pattern で指定した文字列が続く場合に一致と見なされます 【肯定先読み】。 _
        一致文字列は【記憶しません】。 _
        たとえば、'Windows (?=95|98|NT|2000)' は "Windows 2000" の "Windows" には一致 _
        しますが、"Windows 3.1" の "Windows" には一致しません。 _
        先読み処理は、確認した文字を処理済みとはしません。つまり、一致する検索文字列が _
        見つかると、先読みされた文字列の直後からではなく、最後に一致した検索文字列の直後 _
        から、次の検索が始まります。

'(?!pattern) pattern で指定しない文字列が続く場合に一致と見なされます 【否定先読み】。 _
        一致文字列は【記憶しません】。 _
        たとえば、'Windows (?!95|98|NT|2000)' は "Windows 3.1" の "Windows" には一致 _
        しますが、"Windows 2000" の "Windows" には一致しません。 _
        先読み処理は、確認した文字を処理済みとはしません。つまり、一致する検索文字列が _
        見つかると、先読みされた文字列の直後からではなく、最後に一致した検索文字列の直後 _
        から、次の検索が始まります。
top

シート名解決 ― 次に使用できるシート名(_1,_2, ...)を返す関数
 NextSheetName 次のシート名 次の番号 次に使用可能なシート番号 空きシート名
Sub test()
    Dim shtBase As Worksheet
    Dim i As Integer
    
    'ベースシート
    Set shtBase = ActiveWorkbook.Worksheets(1)
    'ベースシートをコピー
    For i = 1 To 5
        shtBase.Copy after:=shtBase
    Next
    'コピーしたシートの名前変更
    With shtBase
        For i = 1 To 5
            .Parent.Worksheets(.Index + i).Name = NextShtName(.Name, .Parent)
        Next
    End With
End Sub

'シート名解決
Public Function NextShtName(BaseName As String, Wb As Workbook) As String
    'BaseNameと同名シートが存在する時は、_1, _2, ... と、次に使用できる名前を返す
    Dim Sht As Worksheet
    Dim ShtName As String
    Dim N As Long
    
    N = -1
    
    Do
        N = N + 1
        If N = 0 Then
            ShtName = BaseName
        Else
            ShtName = BaseName & "_" & CStr(N)
        End If
        
        Set Sht = Nothing
        On Error Resume Next
        Set Sht = Wb.Worksheets(ShtName)
        On Error GoTo 0
        
        If Sht Is Nothing Then
            NextShtName = ShtName
            Exit Do
        End If
    Loop
End Function
top

桁数区切りのSplit関数 ― 文字列を指定桁数で区切って配列に入れて返す関数
 スプリット 桁区切り
Sub test()
    Const S As String = "12ab5678xy1pppzABC9012"
    Dim VV As Variant
    Dim V As Variant
    VV = nSplit(S, 5)
    For Each V In VV
        Debug.Print "*"; V; "*"
    Next
End Sub

'文字列をN桁区切りにして配列(0から)に入れて返す
Private Function nSplit(ByVal D As String, Optional N As Integer = 5) As Variant
    Dim V() As String
    Dim U As Long
    Dim i As Long
    D = Trim$(D)    '最後に付いている余分な空白文字への対応
    U = (Len(D) - 1) \ N
    ReDim V(0 To U)
    For i = 0 To U
        V(i) = Mid$(D, i * N + 1, N)
    Next
    nSplit = V
End Function
top

2次元配列の後方カット ― 2次元配列の【行方向】の余分な部分をカットする関数
 二次元配列 Resize 配列の拡大縮小 配列の伸縮
'2次元配列の後方カット
Private Function CutTail(VV As Variant, LastRow As Long) As Variant
    If LastRow >= UBound(VV) Then
        CutTail = VV
        Exit Function
    End If

    Dim V As Variant
    Dim i As Long, j As Long

    ReDim V(LBound(VV) To LastRow, LBound(VV, 2) To UBound(VV, 2))
    For i = LBound(VV) To LastRow
        For j = LBound(VV, 2) To UBound(VV, 2)
            V(i, j) = VV(i, j)
        Next
    Next

    CutTail = V
End Function
top

ワークシートの存在有無 ― ワークシートが存在するか否かを返す関数
 ワークシート有無 ワークシートの有無 シートの有無 ※ブックの指定がない時はアクティブブックが対象
'ワークシートの存在有無
Private Function ExistSheet(ShtName As String, Optional Book As Workbook) As Boolean
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim Flg As Boolean
    
    Set Wb = Book
    If Wb Is Nothing Then
        Set Wb = ActiveWorkbook
    End If
    
    Flg = False
    For Each Sht In Wb.Worksheets
        If LCase(Sht.Name) = LCase(ShtName) Then
            Flg = True
            Exit For
        End If
    Next
    
    ExistSheet = Flg
    
    Set Wb = Nothing
End Function
top

ファイルリスト ― D&Dでファイルまたはフォルダのリストをテキストファイル(年月日_時分秒.txt)に作成するVBS
 ドラッグアンドドロップ 引数リスト フォルダリスト ArgumentsList
===== ArgList.vbs =====
Option Explicit

const AppliName="ArgList"
dim Res

Res=ArgList

if varType(Res)<>vbBoolean then
    msgbox Res & "件のリストを作成しました。",vbOkonly,AppliName
end if

function ArgList()
    ArgList=False

    dim Args, Arg, Fso, Ts, myPath, myDateTime
    dim Ans, Msg, Ary, C, i, L, temp

    set Args=WScript.Arguments
    if Args.count=0 then
        set Args=nothing
        exit function
    end if

    Msg="名前のみにしますか?" & vbCrLf
    Msg=Msg & vbCrLf
    Msg=Msg & "「はい」=>名前のみ  「いいえ」=>フルパス"
    Msg=Msg & vbCrLf
    Ans=msgbox(Msg, vbYesNoCancel, "引数リスト作成")
    if Ans=vbCancel then
        set Args=nothing
        exit function
    end if

    C=Args.count-1
    redim Ary(C)
    for i=0 to C
        if Ans=vbYes then
            temp=split(Args(i),"\")
            Arg=temp(ubound(temp))
        else
            Arg=Args(i)
        end if
        Ary(i)=Arg
    next

    'L=len(WScript.ScriptName)            'このスクリプトと同じフォルダに作る場合
    'myPath=WScript.ScriptFullName        ' 〃
    'myPath=left(myPath,len(myPath)-L)    ' 〃

    '作成先はデスクトップ固定
    myPath = WScript.CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"

    myDateTime=replace(FormatDateTime(now,vbGeneralDate),"/","")
    myDateTime=replace(myDateTime,":","")
    myDateTime=replace(myDateTime," ","_")
    myPath=myPath & myDateTime & ".txt"

    set Fso=CreateObject("Scripting.FileSystemObject")
    set Ts=Fso.OpenTextFile(myPath, 2, True)
    Ary=join(Ary,vbCrLf)
    Ts.write Ary
    Ts.close

    set Args=nothing
    set Ts=nothing
    set Fso=nothing
    
    ArgList=C+1
end function
top

VBS版のSort ― CsortなどのVBA版をVBS用に書き換えたもの
 vbs用ソート vbs版ソート ランダムソート
===== Sort.vbs =====
Option Explicit

test1
test2
test3

sub test1
    Dim A
    A = Array(4, 2, 1, 7, 8, 4, 2, 5, 9)
    A = Csort(A)
    Msgbox2 join(A,","),0,"",0
end sub

Sub test2()
    Dim A
    Dim Idx
    Dim i
    dim Ans
    
    A = Array(6, 2, 4, 1, 7, 4, 9, 8, 4, 3, 7, 2, 5, 6, 4, 9, 1, 3, 2)
    Idx = MsCombSortI(A)

    Ans=""
    For i = 0 To UBound(A)
        Ans=Ans & "," & A(Idx(i))
    Next
    Ans=mid(Ans,2)

    Msgbox2 Ans,0,"",0
End Sub

sub test3()
    Dim A
    Dim i
    dim Ans
    
    A = Array(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20)
    A = RandomSort(A)

    Ans=""
    For i = 0 To UBound(A)
        Ans=Ans & "," & A(i)
    Next
    Ans=mid(Ans,2)

    Msgbox2 Ans,0,"",0
end sub

function RandomSort(byVal Ary)
    dim U
    dim R  '乱数
    dim Ndx
    dim Ret
    dim i

    U=Ubound(Ary)

    redim R(U)
    Randomize
    for i=0 to U
        R(i)=Rnd
    next

    Ndx=MsCombSortI(R)

    redim Ret(U)
    for i=0 to U
        Ret(i)=Ary(Ndx(i))
    next

    RandomSort=Ret
end function

Function Csort(ByVal Ary)
    '昇順並べ替え、引数は1次元配列のみ可
    Dim L, U
    Dim i
    Dim gap
    Dim Temp
    Dim F
    
    L = 0
    U = UBound(Ary)
    gap = U - L
    F = True
    
    Do While gap > 1 Or F = True
        gap = Int(gap / 1.3)
        If gap = 9 Or gap = 10 Then
            gap = 11
        ElseIf gap < 1 Then
            gap = 1
        End If
        F = False
        For i = L To U - gap
            If Ary(i) > Ary(i + gap) Then
                Temp = Ary(i)
                Ary(i) = Ary(i + gap)
                Ary(i + gap) = Temp
                F = True
            End If
        Next
    Loop
    
    Csort = Ary
End Function

Function MsCombSortI(Ary)
    '昇順インデックスを返す
    '配列引数Aryは1次元限定
    Dim Idx
    Dim L, U
    Dim i
    Dim gap
    Dim Temp
    Dim F
    
    L = 0
    U = UBound(Ary)
    
    'インデックス初期設定
    ReDim Idx(U)
    For i = L To U
        Idx(i) = i
    Next
    
    gap = U - L
    F = True
    
    '並べ替え
    Do While gap > 1 Or F = True
        gap = Int(gap / 1.3)
        If gap = 9 Or gap = 10 Then
            gap = 11
        ElseIf gap < 1 Then
            gap = 1
        End If
        F = False
        For i = L To U - gap
            If Ary(Idx(i)) > Ary(Idx(i + gap)) Then  '降順時は <
                Temp = Idx(i)
                Idx(i) = Idx(i + gap)
                Idx(i + gap) = Temp
                F = True
            ElseIf Ary(Idx(i)) = Ary(Idx(i + gap)) Then
                If Idx(i) > Idx(i + gap) Then   '昇順降順変更しても変更の必要なし
                    Temp = Idx(i)
                    Idx(i) = Idx(i + gap)
                    Idx(i + gap) = Temp
                    F = True
                End If
            End If
        Next
    Loop

    MsCombSortI = Idx
End Function

Function Msgbox2(Msg, Style, Title, Time)
'時間指定なしは、Time=0として呼ぶ
'時間切れ時はTrue(-1)が返る
'×クリック時:Style=vbOKCancelなどで「キャンセル」ボタンがある時 → vbCancel
'              Style=vbOKOnlyなどで「OK」ボタンしか無い時 → vbOK
'              「OK」「キャンセル」共に無い時は「×」は無効(淡色表示)
    Dim WshShell
    Set WshShell = WScript.CreateObject("WScript.Shell")
    Msgbox2 = WshShell.Popup(Msg, Time, Title, Style)
    Set WshShell = Nothing
End Function
top

時限付きメッセージボックス ― WshShellを利用して、通常のメッセージボックスの引数と同じ+時間という形で使えるようにしたもの
Public Function Msgbox2(Optional Msg As String = "", Optional Style As VbMsgBoxStyle = vbOKOnly, _
    Optional Title As String = "Microsoft Excel", Optional T As Integer = 1) As VbMsgBoxResult
        '時間切れ時はTrue(-1)が返る
        '×クリック時:Style=vbOKCancelなどで「キャンセル」ボタンがある時 → vbCancel
        '              Style=vbOKOnlyなどで「OK」ボタンしか無い時 → vbOK
        '              「OK」「キャンセル」共に無い時は「×」は無効(淡色表示)
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    Msgbox2 = WshShell.Popup(Msg, T, Title, Style)
    Set WshShell = Nothing
End Function
top

一括リネームを戻す ― 一括リネームの逆動作。フォルダ名を付加したファイル名から、フォルダ名を除く。
===== ReNameUnDo.vbs =====
Option Explicit

'機能:ReName.vbsで変更したファイル名を元に戻す。ex. 「ABCフォルダ」にて、ABC_xyz.jpg --> xyz.jpg
'使い方:エクスプローラでフォルダをこのスクリプトにD&Dする。複数可。

dim Args
dim fso, fld, fl, fls
dim fldPath, i, j
dim Ans, C

if WScript.Arguments.Count>=1 then
    set Args=WScript.Arguments
    Ans=msgbox("ファイル名からフォルダ名を削除し元に戻します。実行しますか?", vbYesNo)
    if Ans=vbYes then
        set fso=WScript.CreateObject("Scripting.FilesystemObject")
        C=0
        for i=0 to Args.Count-1
            fldPath=Args(i)
            set fld=fso.GetFolder(fldPath)

            redim fls(fld.Files.Count-1)
            j=0
            for each fl in fld.Files
                fls(j)=fl.Path
                j=j+1
            next

            for j=0 to Ubound(fls)
                set fl=fso.GetFile(fls(j))
                '頭がフォルダ名_ならカットする
                if left(fl.Name, len(fld.Name)+1)=(fld.Name & "_") then
                    fl.Name=mid(fl.Name, len(fld.Name)+2)
                    C=C+1
                end if
            next
        next
        set fl=nothing
        set fls=nothing
        set fld=nothing
        set fso=nothing
        msgbox cStr(C) & "個のファイル名を元に戻しました。", vbInformation
    end if
    set Args=nothing
end if
top

一括リネームVBS ― フォルダ内のファイル名を一括して変更するVBS
===== ReName.vbs =====
Option Explicit

'機能:ファイル名にそのフォルダ名を付加する。ex. ABCフォルダのxyz.jpg --> ABC_xyz.jpg
'使い方:エクスプローラでフォルダをこのスクリプトにD&Dする。複数可。

dim Args
dim fso, fld, fl, fls
dim fldPath, i, j
dim Ans, C

if WScript.Arguments.Count>=1 then
    set Args=WScript.Arguments
    Ans=msgbox("ファイル名をフォルダ名_ファイル名、に変更します。実行しますか?", vbYesNo)
    if Ans=vbYes then
        set fso=WScript.CreateObject("Scripting.FilesystemObject")
        C=0
        for i=0 to Args.Count-1
            fldPath=Args(i)
            set fld=fso.GetFolder(fldPath)

            redim fls(fld.Files.Count-1)
            j=0
            for each fl in fld.Files
                fls(j)=fl.Path   '予め元のファイルパス(名前)を配列に取得しておくのがミソ。それをせずに下記でFor Eachで回すと無限ループになる場合がある。
                j=j+1
            next

            for j=0 to Ubound(fls)
                set fl=fso.GetFile(fls(j))
                fl.Name=fld.Name & "_" & fl.Name
                C=C+1
            next
        next
        set fl=nothing
        set fls=nothing
        set fld=nothing
        set fso=nothing
        msgbox cStr(C) & "個のファイル名を変更しました。", vbInformation
    end if
    set Args=nothing
end if
top

ショートカットの一括作成 ― フォルダ内またはサブフォルダ内のファイルへのショートカットを一括して作成するVBS
 ドラッグアンドドロップでショートカットの一括作成 D&Dでショートカット一括作成
===== CreateShortCut.vbs =====
Option Explicit

'機能
'ファイルへのショートカットを、そのフォルダ名_ファイル名.lnkとして作る。
'サブフォルダがあるフォルダを選んだ時
'  各々のサブフォルダ内のファイルへのショートカットを、選んだフォルダ内に作る
'サブフォルダが無いフォルダを選んだ時
'  選んだフォルダ内のファイルへのショートカットを、親フォルダ内に作る
'※つまり、一括で実行したい時はサブフォルダの親フォルダを選択し、個別に実行したい時はサブフォルダ1個を選択すれば良い

Dim Res
Dim WshShell
Dim Fso, Fld, SubFld, Fl
Dim C

'Res=SelectFolder("親フォルダを選択してください。", Null)
Res=WScript.Arguments(0)

If Res<>"" Then
    Set WshShell=WScript.CreateObject("WScript.Shell")

    Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
    Set Fld=Fso.GetFolder(Res)

    C=0
    If Fld.SubFolders.Count>=1 Then
        'サブフォルダ内のファイルへのショートカットを作る
        For Each SubFld In Fld.SubFolders
            For Each Fl In SubFld.Files
                MakeShortcut Fl.Path, Fld.Path & "\" & SubFld.Name & "_" & Fl.Name & ".lnk"
                C=C+1
            Next
        Next
    Else
        'フォルダ内のファイルへのショートカットを親フォルダへ作る
        For Each Fl In Fld.Files
            MakeShortcut Fl.Path, Fld.ParentFolder.Path & "\" & Fld.Name & "_" & Fl.Name & ".lnk"
            C=C+1
        Next
    End If

    Msgbox cStr(C) & "個のショートカットを作成しました。", vbInformation

    Set Fld=Nothing
    Set Fso=Nothing
    Set WshShell=Nothing
End If

Sub MakeShortcut(strSource, strDest)
    Dim oLink
    Set oLink=WshShell.CreateShortcut(strDest)
    With oLink
        .TargetPath=strSource
        '.WindowStyle=1
        '.Hotkey = "CTRL+SHIFT+F"
        '.IconLocation="notepad.exe, 0"
        '.Description = "Shortcut Script"
        '.WorkingDirectory = strDesktop
        .Save
    End With
    Set oLink=Nothing
End Sub


Sub test()
    Dim Fld
    Fld = SelectFolder("", Null)
    'Fld = SelectFolder("選択してね", "c:\")
    If Fld = "" Then
        MsgBox "Cancel or Error", vbExclamation
    Else
        MsgBox Fld
    End If
End Sub

'選択したフォルダのフルパスを返す。キャンセル又はエラーなら""を返す。
Function SelectFolder(Title, RootFolder)  'VBS用にフォルダ選択ダイアログを改良
    Dim Shl   'Shell32.Shell
    Dim Fld   'Folder
    Dim strFld
    Dim Ttl
    
    If Title = "" Then
        Ttl = "フォルダを選択してください。"
    Else
        Ttl = Title
    End If
    
    Set Shl = WScript.CreateObject("Shell.Application")
    '1:コントロールパネルなどの余分なもの非表示  512:新規フォルダ作成ボタン非表示
    If IsNull(RootFolder) Then
        Set Fld = Shl.BrowseForFolder(0, Ttl, 1 + 512)
    Else
        Set Fld = Shl.BrowseForFolder(0, Ttl, 1 + 512, RootFolder)
    End If
    
    strFld = ""
    If Not Fld Is Nothing Then
        On Error Resume Next
        strFld = Fld.Self.Path
        If strFld = "" Then
            strFld = Fld.Items.Item.Path
        End If
        On Error GoTo 0
    End If
    
    If InStr(strFld, "\") = 0 Then strFld = ""
    
    SelectFolder = strFld
    
    Set Fld = Nothing
    Set Shl = Nothing
End Function
top

画像の連続ダウンロードツール ― Webから連番の画像を連続してダウンロードするためのツール
 ピクチャーツール IE操作 IEのコントロール ※Microsoft Internet Controls(C\WINDOWS\system32\shdocvw.dll)に参照設定
'使い方
'1.初期ページをIEで表示し、URLをコピーしておく
'2.SavePictures()を実行
'3.StartURLに上記URLをペースト
'4.EndNumberに最終番号入力
'5.「続けますか?」に対して「OK」クリック
'6.保存ダイアログで場所を指定して保存(場所の指定は一回目のみ)
'7.5に戻るので、必要なだけ繰り返す、途中でやめるときは「キャンセル」クリック

Sub SavePictures()
    Dim IE As InternetExplorer
    Dim urlStart As String
    Dim numStart As Variant
    Dim numEnd As Variant
    Dim Head As String, Ichi As Long, Tail As String
    Dim Ans As Variant
    Dim i As Long
    
    'スタートURL
    urlStart = InputBox("StartURL(ex.http://.../abc001.jpg)?", "StartURL")
    If urlStart = "" Then Exit Sub
    
    '初期番号、頭、尻尾
    numStart = GetLastNumber(urlStart, Ichi)
    If numStart = "" Then Exit Sub
    Head = Left(urlStart, Ichi - 1)
    Tail = Mid(urlStart, Ichi + Len(numStart))
    
    '最終番号
    numEnd = InputBox("EndNumber(ex.60)?", "EndNumber")
    If numEnd = "" Then Exit Sub
    If Not IsNumeric(numEnd) Then Exit Sub
    numEnd = Int(Val(numEnd))
    
    Set IE = New InternetExplorer
    
    With IE
        For i = Val(numStart) To numEnd
            Ans = MsgBox("続けますか?", vbOKCancel)
            If Ans <> vbOK Then Exit For
            
            .Visible = True
            'ページを開き
            .Navigate Head & Format(i, String(Len(numStart), "0")) & Tail
            '開き切るのを待ち
            IeWait IE
            '名前をつけて保存ダイアログ表示(ヘルプではNotPRONPTUSERも可とあったが、実際にはうまく動作しなかった。)
            .ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_PROMPTUSER
            .Visible = False
        Next
        .Quit
    End With
    Set IE = Nothing
End Sub

Sub test()
    Const SS As String = "http://.../abc001.jpg"
    Dim Num As String
    Dim Ichi As Long
    Num = GetLastNumber(SS, Ichi)
    Debug.Print Num, Ichi
End Sub

'URLの最後の番号部分の情報を返す(ex.http://.../abc001.jpgの「001」)
Function GetLastNumber(Exp As String, Ichi As Long) As String
    'S:「001」のスタート位置
    Dim regEx As Object
    Dim Match, Matches
    
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        .Pattern = "[\d]+"
        .IgnoreCase = True
        .Global = True
        Set Matches = .Execute(Exp)
        If Matches.Count >= 1 Then
            Set Match = Matches(Matches.Count - 1)
            Ichi = Match.FirstIndex + 1
            GetLastNumber = Match.Value
        End If
    End With
    Set regEx = Nothing
End Function

Sub IeWait(IE As InternetExplorer)
    With IE
        Do
            If .Busy = True Then
            Else
                If .ReadyState = READYSTATE_COMPLETE Then
                    Exit Do
                End If
            End If
            Application.Wait Now() + TimeSerial(0, 0, 1)
        Loop
    End With
End Sub
top

連続番号間を「〜」に変換 ― 1,2,3,4,6,7,9 ⇒ 1〜4,6〜7,9 のように変換する
 連番変換 連番間を〜に
Sub test()
    Const S As String = "1,2,3,5,8,10,11,12,13,15,17,19,20"
    Dim V As Variant
    Dim A As Variant
    V = SumNumber(S)
    For Each A In V
        Debug.Print A
    Next
End Sub

'昇順の連続・不連続番号(,区切り文字列)を、連番間をxx〜yyという形にして配列で返す
Function SumNumber(Num As String) As Variant
    Dim S As Long
    Dim E As Long
    Dim Ary As Variant
    Dim Flg As Boolean
    Dim Ary2 As Variant
    Dim C As Integer
    
    Ary = Split(Num, ",")
    
    S = LBound(Ary)
    E = S
    
    Do Until S > UBound(Ary)
        E = E + 1
        If E > UBound(Ary) Then
            Flg = True
        Else
            If Val(Ary(E)) = Val(Ary(E - 1)) + 1 Then
                Flg = False
            Else
                Flg = True
            End If
        End If
        
        If Flg Then
            C = C + 1
            If C = 1 Then
                ReDim Ary2(1 To C)
            Else
                ReDim Preserve Ary2(1 To C)
            End If
            If S = E - 1 Then
                Ary2(C) = Ary(S)
            Else
                Ary2(C) = Ary(S) & "〜" & Ary(E - 1)
            End If
            
            S = E
        End If
    Loop
    
    SumNumber = Ary2
End Function
top

VBSから起動3 ― このvbsファイルと同じフォルダ内の同名のxlsファイルを起動する
 マクロ警告対策 ※使い方:起動したいxlsファイルと同じフォルダに下記コードのvbsファイルを、同じ名前で置き、それをダブルクリック
===== 同名ブック起動vbs =====
Dim myPath
myPath=Wscript.ScriptFullName
myPath=Left(myPath, Len(myPath)-4)

Dim Exl
Set Exl=Nothing

On Error Resume Next
Set Exl=GetObject(,"Excel.Application")
On Error Goto 0

If Exl Is Nothing Then
    Set Exl=CreateObject("Excel.Application")
End If

With Exl
    .Visible=True
    .Workbooks.Open myPath & ".xls"
End With

Set Exl=Nothing
top

vbsでLike演算子代わり ― VBSファイル内でLike演算子代わりに使う簡易型の関数
 Like代わり ※以下の例のようなループ内使用は好ましくない。その時は「ファイル名配列取得2」のようにループ外で正規表現のインスタンスを生成する。
===== Likee.vbs =====
Dim myPath
Dim Fls
Dim Msg
Dim i

myPath = CreateObject("WScript.Shell").specialfolders("mydocuments")

Fls = Dirs(myPath, "^c(.)*\.xls$")
If VarType(Fls) = vbBoolean Then
    MsgBox "Not Found"
Else
    On Error Resume Next
    C = 0
    For i = 0 To 3  'Ubound(Fls)
        Msg = Msg & Fls(i) & vbCrLf
    Next
    On Error Goto 0
    Msgbox Msg
End If


'指定フォルダ中の指定パターンのファイル名配列を返す
'(無効なフォルダ指定又はファイルが見つからない場合はFalse)
Private Function Dirs(Path, Patrn)
    Dim FSO  'FileSystemObject
    Dim Fld  'Folder
    Dim Fl   'File
    Dim Fls
    Dim C
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Fld = Nothing
    On Error Resume Next
    Set Fld = FSO.GetFolder(Path)
    On Error GoTo 0
    If Fld Is Nothing Then
        Dirs = False
        Set FSO = Nothing
        Exit Function
    End If

    C = -1
    For Each Fl In Fld.Files
        If Likee(Fl.Name, Patrn, False) Then
            C = C + 1
            If C = 0 Then
                ReDim Fls(0)
            Else
                ReDim Preserve Fls(C)
            End If
            Fls(C) = Fl.Name
        End If
    Next
    
    If C = -1 Then
        Dirs = False
    Else
        Dirs = Fls
    End If
    
    Set FSO = Nothing
    Set Fld = Nothing
End Function

'VBAのLike演算子の代わり。一致:True、不一致:False
Private Function Likee(Moji, Patrn, MatchCase)
    Dim regEx
    Set regEx = New RegExp
    With regEx
        .Pattern = Patrn
        .IgnoreCase = Not MatchCase
        .Global = True
        Likee = .Test(Moji)
    End With
    Set regEx = Nothing
End Function
top

ファイル名配列取得2 ― 指定フォルダ中の指定パターンのファイル名配列を取得する(VBS版、正規表現使用)
 FileNames FileSearch ファイル検索 ファイル名検索 ファイル名取得
===== Dirs.vbs =====
Dim myPath
Dim Fls
Dim Msg
Dim i

myPath = CreateObject("WScript.Shell").specialfolders("mydocuments")

Fls = Dirs(myPath, "^c(.)*\.xls$")    'Likeなら、c*.xls
If VarType(Fls) = vbBoolean Then
    MsgBox "Not Found"
Else
    On Error Resume Next
    C = 0
    For i = 0 To 4  'とりあえず5つ、全部ならUbound(Fls)まで
        Msg = Msg & Fls(i) & vbCrLf
    Next
    On Error Goto 0
    Msgbox Msg
End If


'指定フォルダ中の指定パターンのファイル名配列を返す
'(無効なフォルダ指定又はファイルが見つからない場合はFalse)
Private Function Dirs(Path, Patrn)
    Dim FSO  'FileSystemObject
    Dim Fld  'Folder
    Dim Fl   'File
    Dim Fls
    Dim C
    Dim regEx

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Fld = Nothing
    On Error Resume Next
    Set Fld = FSO.GetFolder(Path)
    On Error GoTo 0
    If Fld Is Nothing Then
        Dirs = False
        Set FSO = Nothing
        Exit Function
    End If

    Set regEx = New RegExp
    With regEx
        .Pattern = Patrn
        .IgnoreCase = True
        .Global = True
    End With

    C = -1
    For Each Fl In Fld.Files
        If regEx.Test(Fl.Name) Then
            C = C + 1
            If C = 0 Then
                ReDim Fls(0)
            Else
                ReDim Preserve Fls(C)
            End If
            Fls(C) = Fl.Name
        End If
    Next
    
    If C = -1 Then
        Dirs = False
    Else
        Dirs = Fls
    End If
    
    Set regEx = Nothing
    Set FSO = Nothing
    Set Fld = Nothing
End Function
top

範囲交換 ― あるセル範囲の値と別のセル範囲の値を、右クリックを使用して簡単に入れ替える
 範囲と範囲の値交換 右クリックでセル交換
※使用方法:
0.シート上のボタンなどでFlgのONOFFを切り替える。
1.ONの状態の時、右クリックすると選択範囲がコピーされる。
2.そのコピー状態の時、別の場所を右クリックすると、コピーされている(破線範囲)と右クリックした範囲の値が交換される。

Option Explicit

Private Flg As Boolean
Private rngSource As Range

Private Sub CommandButton1_Click()
    Flg = Not Flg
    If Flg Then
        Me.CommandButton1.Caption = "ON"
    Else
        Me.CommandButton1.Caption = "OFF"
    End If
    Set rngSource = Nothing
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
    If Not Flg Then Exit Sub
    
    Cancel = True
    Dim S As Variant
    Dim D As Variant
    
    If Application.CutCopyMode = xlCopy Then
        With rngSource
            S = .Value
            D = Target.Resize(.Rows.Count, .Columns.Count).Value
            .Value = D
            Target.Resize(.Rows.Count, .Columns.Count).Value = S
        End With
        Application.CutCopyMode = False
    Else
        Target.Copy
        Set rngSource = Target
    End If
End Sub
top

VBSで計算 ― VBSのみで計算を行なう簡単な例(Excelを使用するより動作は非常に軽快)
 VBSサンプル VBSの例 軽快な動作
===== 公差.vbs =====
Dim Dat
Dim V
Dim A, B, C
Dim Ans
Dim Msg

Msg="径(mm) 公差上(μ) 公差下(μ) の順に入力してください" & Chr(10)
Msg=Msg & "(ex. 10 10 -15)"

Dat=""
Do
    Dat=Inputbox(Msg,"中心値計算",Dat)
    If Dat="" Then Exit Do

    V=Split(Dat)
    A=CDbl(V(0))
    B=CDbl(V(1))/1000
    C=CDbl(V(2))/1000
    Ans=A+(B+C)/2
    Msgbox "中心値(mm)=" & Ans
Loop
top

ブックが開いているか確認 ― 指定ブックが開いているかどうかを返す関数
 オープン済みチェック BookOpenCheck
Sub Test()
    If BookOpend("MyList.xls") Then
        '処理
    Else
        Workbooks.Open "MyList.xls"
    End If
End Sub

'指定ブックがオープン済みならTrue
Public Function BookOpend(Fn As String) As Boolean
    Dim Wb As Workbook
    Dim Flg As Boolean
    For Each Wb In Workbooks
        If LCase(Wb.Name) = LCase(Fn) Then
            BookOpend = True
            Exit Function
        End If
    Next
End Function
top

ワークブックのバックアップ ― Backupフォルダに日付時刻を名前にしてブックをコピー保存する、フォルダは自動作成
 ブックバックアップ ファイルバックアップ ファイルのバックアップ フォルダ自動作成
Sub Test
    BookBackup ActiveWorkbook
End Sub

'ブックを同フォルダ下のBackupフォルダ内にyyyymmdd_hhmmss.xlsで保存
Private Sub BookBackup(Book As Workbook)
    Dim BackupPath As String
    Dim Na As String
    
    BackupPath = Book.Path & "\Backup\"
    If Dir(BackupPath, vbDirectory) = "" Then
        MkDir BackupPath
    End If
    
    Na = Format$(Now(), "yyyymmdd_hhmmss") & ".xls"
    Book.SaveCopyAs BackupPath & Na
End Sub
top

ファイル名配列取得 ― 指定フォルダ中の指定パターンのファイル名配列を取得する(VBA版、Like演算子使用)
 FileNames FileSearch ファイル検索 ファイル名検索 ファイル名取得
Sub test()
    Dim myPath As String
    Dim Fls As Variant
    
    myPath = CreateObject("WScript.Shell").specialfolders("mydocuments")
    
    Fls = Dirs(myPath, "c*[cd]*.xls")
    If VarType(Fls) = vbBoolean Then
        MsgBox "Not Found"
    Else
        ActiveCell.Resize(UBound(Fls)).Value = Application.WorksheetFunction.Transpose(Fls)
    End If

End Sub

'指定フォルダ中の指定パターンのファイル名配列を返す
'(無効なフォルダ指定又はファイルが見つからない場合はFalse)
Function Dirs(Path As String, Pattern As String) As Variant
    Dim Ptn As String
    Dim FSO As Object   'FileSystemObject
    Dim Fld As Object   'Folder
    Dim Fl As Object    'File
    Dim Fls As Variant
    Dim C As Long
    
    Ptn = LCase(Pattern)
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error GoTo Trap
    Set Fld = FSO.GetFolder(Path)
    On Error GoTo 0
    
    For Each Fl In Fld.Files
        If LCase(Fl.Name) Like Ptn Then
            C = C + 1
            If C = 1 Then
                ReDim Fls(1 To 1)
            Else
                ReDim Preserve Fls(1 To C)
            End If
            Fls(C) = Fl.Name
        End If
    Next
    
    If C = 0 Then
        Dirs = False
    Else
        Dirs = Fls
    End If
    
    Set FSO = Nothing
    Set Fld = Nothing
    Exit Function
    
Trap:
    Dirs = False
    Set FSO = Nothing
    Set Fld = Nothing
    Exit Function
    
End Function
top

ドラッグ&ドロップでファイル名取得 ― ファイルアイコンのドラッグ&ドロップでフルパスを取得しシートに表示する。(VBS利用)
 ※使用方法:予めブックを開いた状態で、下記コードのVBSファイルに対象ファイルをD&Dする。
===== フルパス取得.vbs =====
Dim Exl
Dim rngDest
Dim Arg
Dim I

Set Exl=Nothing
Set Arg=WScript.Arguments

Set Exl=GetObject(,"Excel.Application")

With Exl
    Set rngDest=.Worksheets(1).Range("A1")
    For I=0 To Arg.Count - 1
        rngDest.Value=Arg(I)
        Set rngDest=rngDest.Offset(1)
    Next
End With

Set Exl=Nothing
Set rngDest=Nothing
top

オートフィルタ抽出結果数 ― オートフィルタの抽出結果数を返す関数
 オートフィルター 抽出件数 フィルター結果数
Sub test()
    MsgBox AutoFilterCount(ActiveSheet)
End Sub

'オートフィルタ抽出結果数を返す
Function AutoFilterCount(Ws As Worksheet) As Long
    Dim Sum As Long
    Dim RR As Range
    Dim Are As Range
    Dim R As Range
    
    On Error Resume Next
    Set RR = Ws.AutoFilter.Range
    On Error GoTo 0
    If RR Is Nothing Then Exit Function
    
    Set RR = RR.Columns(1)
    Set RR = RR.SpecialCells(xlCellTypeVisible)
    
    For Each Are In RR.Areas
        For Each R In Are
            Sum = Sum + R.Rows.Count
        Next
    Next
    
    AutoFilterCount = Sum - 1
End Function
top

色で並べ替え2 ― セルの色で並べ替え。作業列を追加してColorIndexを書き出し、並べ替えて、作業列を削除する
 セル色で並べ替え セル色で並び替え セルの色で並び替え
Sub 色で並べ替え2()
    Dim RR As Range
    Dim R As Range
    
    Set RR = Range("A1")
    Set RR = Range(RR, RR.End(xlDown))
    
    Application.ScreenUpdating = False
    
    RR.Offset(, 1).EntireColumn.Insert
    
    For Each R In RR.Offset(, 1)
        R.Value = R.Offset(, -1).Interior.ColorIndex
    Next
    
    RR.CurrentRegion.Sort RR.Offset(, 1).Item(1), xlAscending, header:=xlNo

    RR.Offset(, 1).EntireColumn.Delete
    
    Application.ScreenUpdating = True
End Sub
top

オートフィルタ設定の保存と再現 ― オートフィルタのフィルタ設定状態(フィルタ条件)の保存と再生
 フィルタ解除 フィルタ再設定 フィルタの再現
'まず手動でオートフィルタ設定&フィルタを掛けてから実行する
Sub test()
    ManageFilter 1, ActiveSheet
    
    MsgBox "フィルタを解除します。"
    ActiveSheet.ShowAllData
    
    MsgBox "先ほどのフィルタ設定状態を再現します。"
    
    ManageFilter 2, ActiveSheet
    
End Sub

'AutoFilter設定状態の保存と復元
Public Sub ManageFilter(Mode As Integer, Ws As Worksheet)
    'Mode 0:リセット 1:GetFilter 2:SetFilter
    'トップテン指定などは無視、And,Orは可
    'SetFilter時には、予めAutoFilterを設定してからコールすること
    Dim Af As AutoFilter
    Static Flts As Variant
    Dim C As Integer
    Dim i As Integer
    Dim Cr1 As String
    Dim Cr2 As String
    Dim Ope As Long
    
    If Mode = 0 Then
        Flts = Empty
        Exit Sub
    End If
    
    If Mode = 1 Then
        Set Af = Nothing
        On Error Resume Next
        Set Af = Ws.AutoFilter
        On Error GoTo 0
        If Af Is Nothing Then
            Flts = Empty
            Exit Sub
        End If
        
        C = Af.Filters.Count
        ReDim Flts(1 To C, 1 To 4)
        For i = 1 To C
            With Af.Filters(i)
                Flts(i, 1) = .On
                On Error Resume Next
                Flts(i, 2) = .Criteria1
                Flts(i, 3) = .Criteria2
                Flts(i, 4) = .Operator
                On Error GoTo 0
            End With
        Next
        Set Af = Nothing
        Exit Sub
    End If
    
    If Mode = 2 Then
        If IsEmpty(Flts) Then Exit Sub
        
        Set Af = Nothing
        On Error Resume Next
        Set Af = Ws.AutoFilter
        On Error GoTo 0
        If Af Is Nothing Then
            Flts = Empty
            Exit Sub
        End If
        
        C = Af.Filters.Count
        If C <> UBound(Flts) Then
            Flts = Empty
            Set Af = Nothing
            Exit Sub
        End If
        
        On Error Resume Next
        Ws.ShowAllData
        On Error GoTo 0
        
        For i = 1 To C
            If Flts(i, 1) Then
                Ope = Flts(i, 4)
                Cr1 = Flts(i, 2)
                Cr2 = Flts(i, 3)
                If Ope = 0 Then
                    Ws.AutoFilter.Range.AutoFilter i, Cr1
                ElseIf Ope = xlAnd Or Ope = xlOr Then
                    Ws.AutoFilter.Range.AutoFilter i, Cr1, Ope, Cr2
                End If
            End If
        Next
        
        Set Af = Nothing
        Exit Sub
    End If
    
End Sub
top

指定列の8桁文字列を日付に変換 ― 文字列としての8桁の日付を日付型に変換する
 文字日付変換 日付型変換 西暦表示文字列 文字型を日付型に
Sub Test
    CnvDT0 ActiveSheet
End Sub

'指定シートの特定列の8桁文字列を日付に変換する
Private Sub CnvDT0(Sht As Worksheet)
    Dim RR As Range
    Dim A As Variant
    For Each A In Array("B", "C", "G", "H")
        Set RR = Sht.Columns(A)
        Set RR = Intersect(RR, Sht.UsedRange)
        Set RR = Intersect(RR, RR.Offset(1))
        CnvDT1 RR
    Next
End Sub

'指定セル範囲の8桁文字列を日付に変え、書式は「yy/mm/dd」とする
Private Sub CnvDT1(RR As Range)
    Dim R As Range
    For Each R In RR.Cells
        If Len(R.Value) >= 8 Then
            On Error Resume Next
            R.Value = ConvDate(R.Value)
            On Error GoTo 0
        End If
    Next
    RR.NumberFormatLocal = "yy/mm/dd"
End Sub

'8桁の文字列を日付に変換
Private Function ConvDate(DD As String) As Date
    ConvDate = DateSerial(CInt(Left$(DD, 4)), CInt(Mid$(DD, 5, 2)), CInt(Mid$(DD, 7, 2)))
End Function
top

ReadCsv4 ― 長いCSVファイルをシートに分割して読み込む
 CSV分割読み込み 縦長CSV シートへ分割 CSVを分割 シート最大行数以上のCSV読込み
Sub CreateTestData()
    '範囲を指定した整数を羅列した、4列のテキストファイルを作る。
    Dim Fn As String
    Dim N As Long
    Dim i As Long
    Const L2 As Long = 1
    Const U2 As Long = 30
    Const L3 As Long = 1
    Const U3 As Long = 100
    Const L4 As Long = 1
    Const U4 As Long = 70
    
    Fn = ThisWorkbook.Path & "\test.csv"
    N = FreeFile(0)
    
    Open Fn For Output As #N
    Randomize
    For i = 1 To 150000
        Print #N, i; ","; Int((U2 - L2 + 1) * Rnd() + L2) _
            ; ","; Int((U3 - L3 + 1) * Rnd() + L3) _
            ; ","; Int((U4 - L4 + 1) * Rnd() + L4)
    Next
    Close #N
End Sub

'長いCSVファイルをシートに分けて読み込む
Sub ReadCsv4()
    Const maxRow As Long = 65536
    Const Fpath As String = "test.csv"
    Dim VV As Variant   'CSVデータ全体(行分割)
    Dim V As Variant    '定数行毎のデータ(行列分割)
    Dim A As Variant    '列分割用
    Dim Fso As Object   'FileSystemObject
    Dim Txt As Object   'TextStream
    Dim shtDest As Worksheet
    Dim ShtCount As Long
    Dim i As Long, j As Long, k As Long
    Dim Lc As Long, Cc As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Txt = Fso.OpenTextFile(Fpath)
    VV = Split(Txt.ReadAll, vbCrLf)
    If VV(UBound(VV)) = "" Then
        '最後が改行ならその部分をカットする
        ReDim Preserve VV(UBound(VV) - 1)
    End If
    Txt.Close
    
    Cc = UBound(Split(CStr(VV(0)), ","))    '列数
    
    Application.ScreenUpdating = False
    
    For i = 0 To UBound(VV) Step maxRow
        If UBound(VV) - i + 1 < maxRow Then
            Lc = UBound(VV) - i + 1 - 1
        Else
            Lc = maxRow - 1
        End If
        ReDim V(0 To Lc, 0 To Cc)
        '定数行以内で行列に分割
        For j = 0 To Lc
            A = Split(CStr(VV(i + j)), ",")
            For k = 0 To Cc
                V(j, k) = A(k)
            Next
        Next
        'シートへ書き込み
        ShtCount = ShtCount + 1
        If ShtCount = 1 Then
            Set shtDest = Workbooks.Add.Worksheets(1)
        Else
            On Error GoTo AddSheet
            Set shtDest = ActiveWorkbook.Worksheets(ShtCount)
            On Error GoTo 0
        End If
        shtDest.Range("A1").Resize(Lc + 1, Cc + 1).Value = V
    Next
    
    Application.ScreenUpdating = True
    
    Set Txt = Nothing
    Set Fso = Nothing
    
    Exit Sub
    
'足りないシートの補充
AddSheet:
    With ActiveWorkbook
        Set shtDest = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
    End With
    Resume Next
End Sub

'長いCSVファイルをシートに分けて読み込む(プログレスバー付)
Sub ReadCsv4withProgress()
    Const maxRow As Long = 65536
    Const Fpath As String = "test.csv"
    Dim VV As Variant   'CSVデータ全体(行分割)
    Dim V As Variant    '定数行毎のデータ(行列分割)
    Dim A As Variant    '列分割用
    Dim Fso As Object   'FileSystemObject
    Dim Txt As Object   'TextStream
    Dim shtDest As Worksheet
    Dim ShtCount As Long
    Dim i As Long, j As Long, k As Long
    Dim Lc As Long, Cc As Long
    
    Dim myBar As cProgress
    Set myBar = New cProgress
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Txt = Fso.OpenTextFile(Fpath)
    VV = Split(Txt.ReadAll, vbCrLf)
    If VV(UBound(VV)) = "" Then
        '最後が改行ならその部分をカットする
        ReDim Preserve VV(UBound(VV) - 1)
    End If
    Txt.Close
    
    With myBar
        .Max = UBound(VV)
        .Start
        .Value = 0
    End With
    
    Cc = UBound(Split(CStr(VV(0)), ","))    '列数
    
    Application.ScreenUpdating = False
    
    For i = 0 To UBound(VV) Step maxRow
        If UBound(VV) - i + 1 < maxRow Then
            Lc = UBound(VV) - i + 1 - 1
        Else
            Lc = maxRow - 1
        End If
        ReDim V(0 To Lc, 0 To Cc)
        '定数行以内で行列に分割
        For j = 0 To Lc
            A = Split(CStr(VV(i + j)), ",")
            For k = 0 To Cc
                V(j, k) = A(k)
            Next
            
            If (i + j) Mod 1000 = 0 Then
                myBar.Value = i + j
            End If
        Next
        'シートへ書き込み
        ShtCount = ShtCount + 1
        If ShtCount = 1 Then
            Set shtDest = Workbooks.Add.Worksheets(1)
        Else
            On Error GoTo AddSheet
            Set shtDest = ActiveWorkbook.Worksheets(ShtCount)
            On Error GoTo 0
        End If
        shtDest.Range("A1").Resize(Lc + 1, Cc + 1).Value = V
    Next
    
    Application.ScreenUpdating = True
    
    Set Txt = Nothing
    Set Fso = Nothing
    Set myBar = Nothing
    
    Exit Sub
    
'足りないシートの補充
AddSheet:
    With ActiveWorkbook
        Set shtDest = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
    End With
    Resume Next
End Sub
top

可視セルに連番 ― 非表示行を除き、見えているセルのみに連番を振る
 可視行 連続番号 可視範囲 行番号
Sub CreateNumber()
    Dim RR As Range
    Dim R As Range
    Dim C As Long
    
    Set RR = Range("A1")
    Set RR = Range(RR, Cells(Rows.Count, RR.Column).End(xlUp))
    Set RR = RR.SpecialCells(xlCellTypeVisible)
    
    C = 1
    For Each R In RR.Cells
        R.Value = C
        C = C + 1
    Next
End Sub

'使用範囲の1列目に対して連番(こちらの方が実用的か?)
Sub CreateNumber2()
    Dim RR As Range
    Dim R As Range
    Dim C As Long

    Set RR = ActiveSheet.UsedRange.Columns(1)
    Set RR = RR.SpecialCells(xlCellTypeVisible)

    C = 1
    For Each R In RR.Cells
        R.Value = C
        C = C + 1
    Next
End Sub
top

CSV出力2 ― ブック内の各シートをそれぞれ個別のCSVファイルとして作成する
 CSVファイル作成 CSVに変換 CSV変換 CSVに分解
'アクティブブックの各シートをCSVファイルとして作成する
Sub CreateCSV()
    Dim Sht As Worksheet
    Dim myPath As String
    
    myPath = ActiveWorkbook.Path & "\"
    'myPath = ThisWorkbook.Path & "\"
    
    For Each Sht In ActiveWorkbook.Worksheets
        Sht.Copy
        With ActiveWorkbook
            .SaveAs myPath & Sht.Name & ".csv", FileFormat:=xlCSV
            .Close False
        End With
    Next
End Sub
top

掲示板へのコード投稿用インデント変換 ― クリップボード内の半角スペースインデントを全角スペースに変換する
 VBA掲示板 投稿ツール インデント変換ツール ※使い方:クリップボードへコピー後このコードを実行し、掲示板にペーストする
'※重要な注意:掲示板によっては頭のインデント以外の部分も半角空白が1つに縮められる場合があるので、そこは良く確認してください。
'クリップボード内の半角スペースインデントを全角スペースに置き換える
'(Microsoft Forms x.x Object Libraryへの参照設定が必要)
Sub ConvCode()
    Const Before As String = "    "  'ここは半角空白4つ
    Const After As String = "  "
    Dim Doj As DataObject
    Dim V As Variant
    Dim A As Variant
    Dim Head As String
    Dim i As Integer
    
    Set Doj = New DataObject
    With Doj
        .GetFromClipboard
        If .GetFormat(1) Then
            V = Split(.GetText, vbCrLf)
            For Each A In V
                Head = Left$(A, Len(A) - Len(LTrim$(A)))
                Head = Replace(Head, Before, After)
                V(i) = Head & LTrim$(A)
                i = i + 1
            Next
            V = join(V, vbCrLf)
            .SetText V
            .PutInClipboard
        End If
    End With
    Set Doj = Nothing
End Sub
top

オートフィルタの後、必要列のみをコピー
 オートフィルター 列の抽出 指定列のみ ※オートフィルタ(下向き三角▼表示)が設定されている前提
Sub オートフィルタをかけて必要列のみをコピー()
    Dim RR As Range
    '操作対象範囲
    Set RR = Worksheets(1).AutoFilter.Range
    'オートフィルタの対象列とフィルタ条件
    RR.AutoFilter 3, "=2"
    '必要列のみ抽出
    Set RR = Intersect(RR, RR.Worksheet.Range("A:A,D:D,E:E"))
    Set RR = RR.SpecialCells(xlCellTypeVisible)
    'コピー&貼り付け
    RR.Copy Worksheets(2).Range("C10")
    'すべて表示、に戻しておく
    RR.Worksheet.ShowAllData
End Sub
top

コマンドボタンで順繰り表示 ― 実行する度に、いくつかの値の表示を順に繰り返す(A, B, C, D, A, B, ...)
 順次表示 繰り返し表示 ループ表示 ※下記は実行する度にA1の値が"出社", "休憩", "食事", "帰宅"で繰り返される
Sub ShowStatus()
    Dim V As Variant
    Dim i As Integer
    
    '最後の値として最初の値を入れてあるのがミソ
    V = Array("出社", "休憩", "食事", "帰宅", "出社")

    With Range("A1")
        For i = 0 To UBound(V) - 1
            '現在の値が見つかれば、配列の次の値を設定
            If .Value = V(i) Then
                .Value = V(i + 1)
                Exit Sub
            End If
        Next
        '見つからなければ、配列の最初の値を設定
        .Value = V(0)
    End With
End Sub
top

最終行取得3 ― 複数列の最終行への参照を返す(最下行の非表示対応、但しフィルタによる非表示は非対応)
 最下行選択 複数列中の最終行
'複数列の最終行への参照を返す(最下行の非表示対応、但しフィルタによる非表示は非対応)
Public Function GetLastRange(ByVal RR As Range) As Range
    Dim rngFind As Range
    Set RR = RR.EntireColumn
    Set rngFind = RR.Find(what:="*", LookIn:=xlFormulas, _
        searchorder:=xlByRows, searchdirection:=xlPrevious)
    If rngFind Is Nothing Then
        Set GetLastRange = RR.Rows(1)
    Else
        Set GetLastRange = Intersect(RR, rngFind.EntireRow)
    End If
End Function
top

同一コード毎のデータ結合 ― 同一コードに対するデータを区切り文字を使って結合する
 並べ替え 統合 同一値 同じ値 ※データはコードで並べ替え済みの前提
'1 a   1 a、b
'1 b ⇒ 2 c
'2 c   3 d、e、f
'3 d
'3 e
'3 f

'同一コードのデータを結合する
Sub Summary()
    Dim R As Range
    Dim rngDest As Range
    Dim Code As String
    Dim SS As String
    
    Set R = Range("A1")    'コードの先頭セル
    Set rngDest = Range("D1")    '書き込み先先頭セル
    
    Do Until R.Value = ""
        If Code = "" Then
            Code = R.Value
            SS = R.Offset(, 1).Value
        ElseIf R.Value = Code Then
            SS = SS & "、" & R.Offset(, 1).Value
        Else
            rngDest.Value = Code
            rngDest.Offset(, 1).Value = SS
            Set rngDest = rngDest.Offset(1)
            
            Code = R.Value
            SS = R.Offset(, 1).Value
        End If
        Set R = R.Offset(1)
    Loop
    If Code <> "" Then
        rngDest.Value = Code
        rngDest.Offset(, 1).Value = SS
    End If
End Sub
top

プログレスバー ― ステータスバーを利用したプログレスバークラスとその使用例
 ProgressBar StatusBar ■■■■■■■■■■■■■■□□□□□□ 70% 残り0:00:25 お待ち下さい...
===== 標準モジュール ====
Sub test()
    Dim myBar As cProgress
    Dim myPath As String
    Dim Fname As String
    Dim Cmax As Long
    
    'マイドキュメント
    myPath = CreateObject("Wscript.Shell").SpecialFolders("MyDocuments") & "\"
    
    'ファイル数を予めカウント
    Fname = Dir(myPath & "b*.xls")
    Do Until Fname = ""
        Cmax = Cmax + 1
        Fname = Dir()
    Loop
    
    If Cmax = 0 Then Exit Sub
    
    'プログレスバー準備
    Set myBar = New cProgress
    With myBar
        .Style = plBarAndPercentAndRestTime
        .Min = 0
        .Max = Cmax
        .Msg = "処理しています..."
        .Start  '残り時間(RestTime)表示時は必須
    End With
    
    '処理(開いて閉じるだけ)
    Application.ScreenUpdating = False
    Fname = Dir(myPath & "b*.xls")
    Do Until Fname = ""
        With Workbooks.Open(myPath & Fname, ReadOnly:=True)
            myBar.Value = myBar.Value + 1   'プログレスバー更新
            Application.Wait Now + TimeSerial(0, 0, 2)
            .Close False
        End With
        Fname = Dir()
    Loop
    Application.ScreenUpdating = True
    
    Set myBar = Nothing
End Sub

===== cProgress クラスモジュール =====
Option Explicit

Public Enum plStyle
    plBarOnly = 0                   'バーのみ
    plBarAndPercent = 1             'バー+%
    plBarAndRestTime = 2            'バー+残り時間
    plBarAndPercentAndRestTime = 3  'バー+%+残り時間
End Enum

Private maxLen As Long      'プログレスバーの文字列長
Private StartTime As Date   '実行開始時間
Private MinVal As Long      '最小値
Private MaxVal As Long      '最大値
Private myVal As Long       '現在値
Private myStyle As plStyle  '表示の仕方
Private myDisplayStatusBar As Boolean   'ステータスバーの初期状態
Private myMsg As String     'メッセージ表示

Public Property Let Length(L As Long)
    maxLen = L
End Property

Public Sub Start()
    StartTime = Now
End Sub

Public Property Let Min(MinValue As Long)
    MinVal = MinValue
End Property
Public Property Get Min() As Long
    Min = MinVal
End Property

Public Property Let Max(MaxValue As Long)
    MaxVal = MaxValue
End Property
Public Property Get Max() As Long
    Max = MaxVal
End Property

Public Property Let Style(V As plStyle)
    If V >= 0 And V <= 3 Then
        myStyle = V
    End If
End Property

Public Property Let Msg(Message As String)
    myMsg = Message
    If myMsg <> "" Then
        If (Left$(myMsg, 1) <> " ") And (Left$(myMsg, 1) <> " ") Then
            myMsg = " " & myMsg
        End If
    End If
End Property

Private Sub Class_Initialize()
    maxLen = 20
    MinVal = 0
    MaxVal = 100
    myVal = 0
    myStyle = plBarAndPercent
    myDisplayStatusBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    myMsg = ""
    Start
End Sub

Private Sub Class_Terminate()
    Application.StatusBar = False
    Application.DisplayStatusBar = myDisplayStatusBar
End Sub

Public Property Let Value(V As Long)
    Dim P As Long
    Dim Zan As Date
    Dim Bar As String
    Dim Lvl As Long
    
    If MaxVal <= MinVal Then MaxVal = MinVal + 1 '不正設定対策
    
    If V < MinVal Then
        myVal = MinVal
    ElseIf V > MaxVal Then
        myVal = MaxVal
    Else
        myVal = V
    End If
    
    P = (myVal - MinVal) / (MaxVal - MinVal) * 100
    If P > 0 Then
        Zan = (Now - StartTime) / (P / 100) '予想される総処理時間
        Zan = Zan * (1 - (P / 100))         '残時間
    End If
    
    Bar = String$(maxLen, "□")
    If P > 0 Then
        Lvl = maxLen * (P / 100)
        Mid$(Bar, 1, Lvl) = String$(Lvl, "■")
        Select Case myStyle
            Case plBarAndPercent
                Bar = Bar & P & "%"
            Case plBarAndRestTime
                Bar = Bar & "残り" & Zan
            Case plBarAndPercentAndRestTime
                Bar = Bar & P & "% 残り" & Zan
        End Select
    End If
    
    Application.StatusBar = Bar & myMsg
End Property
Public Property Get Value() As Long
    Value = myVal
End Property
top

最終行取得2 ― 複数列の内の最終行を取得する(実用版)
 最下行選択 複数列中の最終行
Sub Test
    GetLastRange(Selection).Select
End Sub

'複数列の最終行への参照を返す
Public Function GetLastRange(RR As Range) As Range
    Dim rngLast As Range
    Dim A As Long, B As Long
    Dim R As Range
    Dim E As Range

    A = RR.Column
    B = A + RR.Columns.Count - 1
    With RR.Worksheet
        Set rngLast = .Range(.Cells(.Rows.Count, A), .Cells(.Rows.Count, B))
    End With
    
    For Each R In rngLast.Cells
        Set R = R.End(xlUp)
        If E Is Nothing Then Set E = R
        If R.Row > E.Row Then
            Set E = R
        End If
    Next

    Set GetLastRange = Intersect(E.EntireRow, rngLast.EntireColumn)
End Function
top

最終行取得 ― 複数列の内の最終行を取得する
 最下行選択 複数列中の最終行
Sub test()
    'B,C,D列の内の最下行を選択する
    Dim R As Range
    Dim E As Range
    
    For Each R In Range("B65536:D65536")
        Set R = R.End(xlUp)
        If E Is Nothing Then Set E = R
        If R.Row > E.Row Then
            Set E = R
        End If
    Next
    E.Select
End Sub
top

添付ツールバーマクロ ― ブックにツールバーを添付し、それにマクロを登録する場合のOnActionの再設定例
===== ThisWorkbook =====
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.CommandBars("ユーザー設定 1").Visible = False
End Sub

Private Sub Workbook_Open()
    Dim M As String
    Dim V As Variant
    Dim i As Integer
    
    With Application.CommandBars("ユーザー設定 1")
        .Visible = True
        For i = 1 To .Controls.Count
            With .Controls(i)
                M = .OnAction
                V = Split(M, "!")
                M = V(UBound(V))
                .OnAction = M
            End With
        Next
    End With
End Sub
top

FindSample ― Findメソッドの使い方、最終セルの次(=最初のセル)から検索する例
 セルの検索 セル検索の基本 Findの基本的な使い方
Sub FindSample()
    Dim RR As Range
    Dim F As Range
    Dim FirstAddress As String
    
    Set RR = Range("A1:J20")
    With RR
        Set F = .Find(what:="aaa", after:=.Cells(.Count))
        If F Is Nothing Then
            MsgBox "Not Found!", vbExclamation
            Exit Sub
        End If
        
        FirstAddress = F.Address
        Do
            '処理
            Debug.Print F.Address
            
            Set F = .FindNext(F)
        Loop Until F.Address = FirstAddress
    End With
End Sub
top

選択範囲を画像で保存 ― セル選択範囲を画像ファイルとして保存する
 選択範囲を画像で保存 セルを画像に変換 グラフを画像ファイルとして保存 グラフ画像ファイル変換
Sub 選択範囲を画像ファイルに保存()
    With Selection
        .CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        With ActiveCell.Worksheet.ChartObjects.Add(.Left, .Top, .Width, .Height)
            With .Chart
                .Paste
                .Export "test.gif", "gif"
            End With
            .Delete
        End With
    End With
End Sub
top

RenameFiles ― フォルダ内のファイル名を一括して変更(頭に特定文字を付ける例)
 ファイル名一括変更 ファイル名をまとめて変更
Sub RenameFiles()
    Dim myPath As String
    Dim Fname As String
    Dim Fnames As Variant
    Dim C As Integer
    Dim i As Integer
    
    Const Head As String = "d-"
    
    myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    myPath = myPath & "\ゆうこりんTemp4\"
    
    Fname = Dir(myPath & "*.jp*")
    Do Until Fname = ""
        If LCase(Fname) Like "*.jpg" Or LCase(Fname) Like "*.jpeg" Then
            C = C + 1
            If C = 1 Then
                ReDim Fnames(1 To 1)
            Else
                ReDim Preserve Fnames(1 To C)
            End If
            Fnames(C) = Fname
        End If
        Fname = Dir()
    Loop
    
    For i = 1 To C
        Name myPath & Fnames(i) As myPath & Head & Fnames(i)
    Next
End Sub
top

一括印刷 ― 印刷様式のシートの必要個所へ他のリストから差込し、必要枚数分のシートを含む一時ブックを作成して印刷する
 差込印刷 差し込み印刷 差込み印刷
Sub 一括印刷()
    Dim RR As Range
    Dim R As Range
    Dim sht印刷 As Worksheet
    Dim rng住所 As Range
    Dim wbPrint As Workbook
    
    '住所一覧の在るセル範囲
    Set RR = Worksheets("住所一覧").Range("A1")
    Set RR = Range(RR, RR.End(xlDown))
    
    '印刷様式シート
    Set sht印刷 = Worksheets("封筒印刷")
    'そのシートの中の住所記入セル
    Set rng住所 = sht印刷.Range("A1")
    
    '印刷用の一時的なブックを、各住所を書き込んだシートをコピーして作成
    For Each R In RR
        rng住所.Value = R.Value
        If wbPrint Is Nothing Then
            sht印刷.Copy
            Set wbPrint = ActiveWorkbook
        Else
            sht印刷.Copy after:=wbPrint.Sheets(wbPrint.Sheets.Count)
        End If
    Next
    
    '印刷用の一時的なブックを印刷して、保存せずに終了
    wbPrint.Sheets.PrintPreview
    wbPrint.Close False
End Sub
top

ブックを開かずに値を取得 ― 他の開いていないブックへのリンク式を設定して値に変換することによりブックを開かずに値を得る例
 リンク式 リンクして値を取得 他ブックへリンク Formulaを設定、値に変換
Sub ブックを開かずに値を取得()
    Const myPath As String = "c:\my documents"
    Const BookName As String = "book2.xls"
    Const SheetName As String = "Sheet1"
    Const myAddress As String = "$A:$A"
    Dim myFormula As String
    
    myFormula = "=SUM('" & myPath & "\[" & BookName & "]" _
        & SheetName & "'!" & myAddress & ")"
    
    Range("A1").Formula = myFormula
    Range("A1").Value = Range("A1").Value
End Sub
top

重複無しで抽出2 ― Dictionaryを使用した実用版
 重複なし ユニーク値抽出
'Rangeを受け、重複の無い一次元配列を返す
Public Function GetSummary(RR As Range) As Variant
    '返す配列の添え字下限は0
    Dim R As Range
    Dim Dic As Object
    Dim K As String
    Dim V As Variant
    
    Set Dic = CreateObject("Scripting.Dictionary")
    For Each R In RR.Cells
        K = R.Value
        If K <> "" Then
            Dic(K) = Empty
        End If
    Next
    V = Dic.keys
    Set Dic = Nothing
    
    GetSummary = Csort(V)    '並べ替え不要ならCsort()は不要
End Function
top

列折り返し4 ― 長い列データを指定行数、指定列数で折り返し、ページに分割する(元データは2列限定、セル範囲のコピペによる簡易版)
 列の折り返し 列折返し 流し込み ページ分割
Sub 列折り返し4()
    Const 行数 As Long = 50
    Const 列数 As Long = 4
    Dim RR As Range
    Dim rngDest As Range
    Dim j As Long
     
    Set RR = Worksheets("Sheet1").Range("A1")
    Set RR = RR.Resize(行数, 2)
     
    Set rngDest = Worksheets("Sheet2").Range("A1")
     
    j = 0
    Do Until RR.Cells(1).Value = ""
        j = j + 1
        If j > 列数 Then
            j = 1
            Set rngDest = rngDest.Offset(行数)
        End If
        RR.Copy rngDest.Offset(, (j - 1) * 2)
        Set RR = RR.Offset(行数)
    Loop
End Sub
top

タブ→スペース ― 文字列中のvbTabを" "に置換え、空白文字で桁揃えをする
 Tab2Space タブスペース変換 タブをスペースに
Sub test()
    Dim a As String, b As String
    a = "123" & vbTab & "あ" & vbTab & "1234" & vbTab & "END"
    b = Tab2Spc(a)
    ActiveCell.Value = a            'ActiveCellと
    ActiveCell.Offset(1).Value = b  '一つ下のセルの値をメモ帳にコピペして結果を確認して下さい
End Sub

Function Tab2Spc(SS As String) As String
    Const TabLen As Integer = 8
    Dim i As Integer
    Dim S As String
    Dim S2 As String
    For i = 1 To Len(SS)
        S = Mid$(SS, i, 1)
        If S = vbTab Then
            S2 = S2 & Space$(TabLen - LenB(StrConv(S2, vbFromUnicode)) Mod TabLen)
        Else
            S2 = S2 & S
        End If
    Next
    Tab2Spc = S2
End Function
top

セルインデックス ― 特定セル範囲内におけるアクティブセルのインデックスを返す
 Cell.Index セルのインデックス Range内Index ユーザーフォーム上のボタンからのセル移動指示などに利用
Private Function CellIndex(myRange As Range) As Long
    '特定セル範囲内における、ActiveCellのIndexを返す
    Dim R As Long, C As Long
    If Intersect(myRange, ActiveCell) Is Nothing Then
        CellIndex = 0
        Exit Function
    End If
    
    With myRange
        R = ActiveCell.Row - .Row + 1
        C = ActiveCell.Column - .Column + 1
        CellIndex = (R - 1) * .Columns.Count + C
    End With
End Function
top

疑似はんこ ― メニューバーに「印」、その下に「○」「◎」「△」ボタンを追加、押下でチェック、その状態でセル選択で印書込み
 ハンコ はんこ 印 チェック State
===== ThisWorkbookモジュール =====
Option Explicit

Private WithEvents ExlApp As Application
Private Const MenuCaption As String = "印"

Private Sub ExlApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    If Marker = "" Then Exit Sub
    Dim R As Range
    For Each R In Target
        If R.Value <> Marker Then
            R.Value = Marker
        Else
            R.ClearContents
        End If
    Next
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set ExlApp = Nothing
    DeleteMenu
End Sub

Private Sub Workbook_Open()
    Set ExlApp = Application
    AddMenu
End Sub

Private Sub AddMenu()
    Dim myMenu As CommandBarPopup
    Set myMenu = Application.CommandBars("WorkSheet Menu Bar").Controls.Add(Type:=msoControlPopup, temporary:=True)
    myMenu.Caption = MenuCaption
    With myMenu.CommandBar.Controls.Add(Type:=msoControlButton)
        .Caption = "○"
        .OnAction = "SetMarker"
    End With
    With myMenu.CommandBar.Controls.Add(Type:=msoControlButton)
        .Caption = "◎"
        .OnAction = "SetMarker"
    End With
    With myMenu.CommandBar.Controls.Add(Type:=msoControlButton)
        .Caption = "△"
        .OnAction = "SetMarker"
    End With
    Set myMenu = Nothing
End Sub

Private Sub DeleteMenu()
    On Error Resume Next
    Application.CommandBars("WorkSheet Menu Bar").Controls(MenuCaption).Delete
    On Error GoTo 0
End Sub

===== 標準モジュール =====
Option Explicit

Public Marker As String

Private Sub SetMarker()
    Dim Button As CommandBarButton
    Dim B As CommandBarButton
    
    On Error Resume Next
    Set Button = Application.CommandBars.ActionControl
    On Error GoTo 0
    
    If Button Is Nothing Then
        Marker = ""
    Else
        With Button
            If .State = msoButtonDown Then
                .State = msoButtonUp
                Marker = ""
            Else
                For Each B In .Parent.Controls
                    B.State = msoButtonUp
                Next
                .State = msoButtonDown
                Marker = .Caption
            End If
        End With
    End If
End Sub
top

ドラッグ&ドロップでVBSから起動 ― エクセルブックアイコン又はショートカットをD&Dして起動するVBS
 ドラッグ&ドロップ VBSから起動
===== DragDrop.vbs =====
Dim Exl
Dim Arg
Dim I

Set Exl=Nothing
Set Arg=WScript.Arguments

On Error Resume Next
Set Exl=GetObject(,"Excel.Application")
On Error Goto 0

If Exl Is Nothing Then
    Set Exl=CreateObject("Excel.Application")  '新規インスタンスの時はアドインが有効にならない(TT)
End If

With Exl
    .Visible=True
    For I=0 To Arg.Count - 1
        .Workbooks.Open Arg(I)
    Next
End With

Set Exl=Nothing
top

VBSから起動 ― VBSからマクロ警告なしでブックを開く
 vbsから起動 vbsからbookを開く GetObject CreateObject  参考:WigMenu どれでもマクロ
===== BookOpen.vbs =====
Dim Exl
Set Exl=Nothing

On Error Resume Next
Set Exl=GetObject(,"Excel.Application")
On Error Goto 0

If Exl Is Nothing Then
    Set Exl=CreateObject("Excel.Application")  '新規インスタンスの時はアドインがLoadされない(TT)
End If

With Exl
    .Visible=True
    .Workbooks.Open "test.xls"
End With

Set Exl=Nothing
top

矢印以外の直線のみの処理
 直線のみ 矢印以外 AutoShape Arrow
Sub 矢印以外の直線削除()
    Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes
        If Shp.Type = msoLine Then
            If Shp.Line.EndArrowheadStyle = msoArrowheadNone _
            And Shp.Line.BeginArrowheadStyle = msoArrowheadNone Then
                'Shp.Delete
                Debug.Print Shp.Name
            End If
        End If
    Next
End Sub
top

ユーザーフォームのみを表示する ― 起動時にエクセルを表示せずにフォームのみを表示し、ユーザーにエクセルを意識させない
 VBSから起動する UserFormのみ表示 Excel非表示 ※ブックは.xla, .xls のどちらでも構わない、但しWin95ではいずれでもVBS上でエラー
===== Test.vbs =====
set Exl=CreateObject("Excel.Application")
With Exl
    set Wb=.Workbooks.Open("Book1.xls")
    Wb.ShowForm
    .Visible=True   'Formクローズ後Excel.Quitなら不要
End With
set Wb=Nothing
set Exl=Nothing

===== Book1.xls ThisWorkbook =====
Public Sub ShowForm()
    UserForm1.Show
End Sub

===== Book1.xls UserForm1 =====
Private Sub CommandButton1_Click()
    Unload Me
    Application.Quit   'この行が無い時は上記 .Visible=Trueは必須。無いとインスタンスが残ってしまう。
End Sub
top

簡易選択入力フォーム ― ほぼコードだけで実現したユーザーフォームによるリスト選択モジュール
 UserForm1 リストボックス クラス cListBox
===== UserForm1 =====
新規ユーザーフォームUserForm1を手作業で挿入する、デザインやコード記述はいっさい不要

===== 標準モジュール =====
Sub クラスをそのまま利用()
    Dim myList As cListBox
    Dim myArray As Variant
    
    myArray = Array("a", "b", "c", "d", "e")
    Set myList = New cListBox
    With myList
        .Title = "選択してください。"
        .List = myArray
        .Index = 2
        .ShowForm
        If .Status <> vbOK Then
            MsgBox "キャンセルしました。"
        Else
            MsgBox myArray(.Index)
        End If
    End With
    
    Set myList = Nothing
End Sub

Sub 関数を通して利用()
    Dim L As Variant
    Dim A As Integer
    L = Array("a", "b", "c", "d", "e")
    A = Lst(L, "選択してください。")
    If A = -1 Then
        MsgBox "キャンセルまたは未選択"
    Else
        MsgBox L(A)
    End If
End Sub

Function Lst(L As Variant, T As String) As Integer
    Dim myList As cListBox
    Set myList = New cListBox
    With myList
        .Title = T
        .List = L
        .ShowForm
        If .Status <> vbOK Then
            Lst = -1
        Else
            Lst = .Index
        End If
    End With
    Set myList = Nothing
End Function

===== クラスモジュール(cListBox) =====
Option Explicit

Private UForm As UserForm1
Private WithEvents lstListBox As MSForms.ListBox
Private Idx As Integer
Private WithEvents cmdOK As MSForms.CommandButton
Private WithEvents cmdCancel As MSForms.CommandButton
Private ClickedButton As Integer

Private Sub Class_Initialize()
    Set UForm = New UserForm1
    Set lstListBox = UForm.Controls.Add("Forms.ListBox.1")
    lstListBox.Move 20, 20, 100, 120
    Idx = -1
    
    Set cmdOK = UForm.Controls.Add("Forms.CommandButton.1")
    With cmdOK
        .Move 170, 20, 50, 20
        .Caption = "OK"
        .Accelerator = "O"
        .Default = True
    End With
    
    Set cmdCancel = UForm.Controls.Add("Forms.CommandButton.1")
    With cmdCancel
        .Move 170, 50, 50, 20
        .Caption = "Cancel"
        .Accelerator = "C"
        .Cancel = True
    End With
    
    ClickedButton = vbCancel
End Sub

Private Sub Class_Terminate()
    Set lstListBox = Nothing
    Set cmdOK = Nothing
    Set cmdCancel = Nothing
    Set UForm = Nothing
End Sub

Public Property Get Index() As Integer
    Index = Idx
End Property

Public Property Let Index(Ndx As Integer)
    Idx = Ndx
    On Error Resume Next  'ListとIndexどちらを先に設定しても良いように
    lstListBox.ListIndex = Idx
    On Error GoTo 0
End Property

Public Property Get Status() As Integer
    Status = ClickedButton
End Property

Public Property Let List(L As Variant)
    Dim A As Variant
    With lstListBox
        .Clear
        For Each A In L
            .AddItem A
        Next
        .ListIndex = Idx
    End With
End Property

Public Sub ShowForm()
    UForm.Show
End Sub

Public Property Let Title(Ttl As String)
    UForm.Caption = Ttl
End Property

Private Sub cmdCancel_Click()
    ClickedButton = vbCancel
    Unload UForm
End Sub

Private Sub cmdOK_Click()
    ClickedButton = vbOK
    Unload UForm
End Sub

Private Sub lstListBox_Click()
    Idx = lstListBox.ListIndex
End Sub
top

FolderList ― 指定フォルダ以下の全サブフォルダのリストをシート上に階層表示する
 フォルダリスト 再帰処理 フォルダサイズ ※MicrosoftScriptingRuntimeに参照設定
Option Explicit

Private R As Long

Sub myList()
    Dim Fso As FileSystemObject
    Dim Fl As Folder
    Dim C As Integer
    
    Set Fso = New FileSystemObject
    R = 1: C = 1
    Set Fl = Fso.GetFolder("c:\my documents")
    
    Application.ScreenUpdating = False
    FolderList Fl, C
    Application.ScreenUpdating = True
    
    Set Fl = Nothing
    Set Fso = Nothing
End Sub

Private Sub FolderList(PFl As Folder, C As Integer)
    Dim Fls As Folders
    Dim Fl As Folder
    
    Cells(R, C).Value = PFl.Name & " --- " & _
        PFl.DateLastModified & " --- " _
        & Format(PFl.Size, "#,#")
    R = R + 1
    
    Set Fls = PFl.SubFolders
    
    If Fls.Count > 0 Then
        For Each Fl In Fls
            FolderList Fl, C + 1
        Next
    End If
End Sub
top

横連結でCSV出力 ― ワークシートを横に連結した形でCSVに出力する例
 横連結 CSV
Sub CSV作成()
    'Sheet1,2,3を横に連結して出力
    Dim myPath As String
    Dim N As Integer
    
    Dim mySheets As Variant
    Dim maxRow As Long, maxColumn As Long
    Dim i As Long, j As Long, k As Long
    Dim Flg As Boolean
    
    mySheets = Array("Sheet1", "Sheet2", "Sheet3")
    
    With Worksheets(mySheets(0)).UsedRange
        maxRow = .Rows.Count
        maxColumn = .Columns.Count
    End With
    
    myPath = ActiveWorkbook.Path & "\Test.csv"
    N = FreeFile
    
    Open myPath For Output As #N
    
    For i = 1 To maxRow
        Flg = True
        For j = 0 To UBound(mySheets)
            With Worksheets(mySheets(j))
                For k = 1 To maxColumn
                    If Flg Then
                        Print #N, .Cells(i, k).Value;
                    Else
                        Print #N, ","; .Cells(i, k).Value;
                    End If
                    Flg = False
                Next k
            End With
        Next j
        Print #N, ""
    Next i
    
    Close #N
End Sub
top

列折り返し ― 長い列データを指定行数、指定列数で折り返し、ページに分割する
 列の折り返し 列折返し 流し込み ページ分割
1
2
3
4
5
6
7
8
9		
10		
		
↓	(2行3列の場合)	
		
1	3	5
2	4	6
7	9	
8	10	

Sub 列折り返し1()   '素直な思考のアルゴリズム(元データのループを中心にして、行・列・ページをインクリメント)
    '1列のデータを指定行、指定列で折り返す
    Dim VV As Variant
    Dim V2 As Variant
    Dim RR As Range
    Dim rngDest As Range
    Dim C As Long
    Dim ii As Long
    Dim i As Long, j As Long, P As Long
    Const 指定行 As Integer = 57
    Const 指定列 As Integer = 6
    
    Set RR = Range("A1")
    Set RR = Range(RR, RR.End(xlDown))
    VV = RR.Value
    
    C = 指定行 * 指定列
    i = UBound(VV) \ C
    If (UBound(VV) Mod C) <> 0 Then
        i = i + 1
    End If
    i = i * 指定行
    ReDim V2(1 To i, 1 To 指定列)
    
    i = 0: j = 1: P = 1
    For ii = 1 To UBound(VV)
        i = i + 1
        If i > 指定行 Then
            i = 1
            j = j + 1
            If j > 指定列 Then
                j = 1
                P = P + 1
            End If
        End If
        V2((P - 1) * 指定行 + i, j) = VV(ii, 1)
    Next
    
    Set rngDest = Worksheets.Add.Range("A1")
    rngDest.Resize(UBound(V2), UBound(V2, 2)).Value = V2
End Sub

Sub 列折り返し2()   '拡張しやすい形のアルゴリズム(ページ・列・行の階層ループの中で元データをインクリメント)
    '1列のデータを指定行、指定列で折り返す
    Dim VV As Variant
    Dim V2 As Variant
    Dim RR As Range
    Dim rngDest As Range
    Dim C As Long
    Dim ii As Long
    Dim i As Integer, j As Integer
    Dim Pmax As Integer, P As Integer
    Const 指定行 As Integer = 57
    Const 指定列 As Integer = 6
    
    Set RR = Range("A1")
    Set RR = Range(RR, RR.End(xlDown))
    VV = RR.Value
    
    C = 指定行 * 指定列
    Pmax = UBound(VV) \ C
    If (UBound(VV) Mod C) <> 0 Then
        Pmax = Pmax + 1
    End If
    ReDim V2(1 To Pmax * 指定行, 1 To 指定列)
    
    i = 1: j = 1: P = 1: ii = 1
    Do While P <= Pmax And ii <= UBound(VV)
        Do While j <= 指定列 And ii <= UBound(VV)
            Do While i <= 指定行 And ii <= UBound(VV)
                V2((P - 1) * 指定行 + i, j) = VV(ii, 1)
                i = i + 1
                ii = ii + 1
            Loop
            i = 1
            j = j + 1
        Loop
        j = 1
        P = P + 1
    Loop
    
    Set rngDest = Worksheets.Add.Range("A1")
    rngDest.Resize(UBound(V2), UBound(V2, 2)).Value = V2
End Sub

Sub 列折り返し3()   '列折り返し2()の拡張版、元データ列数が任意数に対応
    '3列で対のデータを指定行、指定列(倍数)で折り返す
    Dim VV As Variant
    Dim V2 As Variant
    Dim RR As Range
    Dim rngDest As Range
    Dim C As Long
    Dim ii As Long
    Dim i As Integer, j As Integer, k As Integer
    Dim Pmax As Integer, P As Integer
    Const 元列数 As Integer = 3
    Const 指定行 As Integer = 57
    Const 指定列 As Integer = 4
    
    Set RR = Range("A1")
    Set RR = Range(RR, RR.End(xlDown)).Resize(, 元列数)
    VV = RR.Value
    
    C = 指定行 * 指定列
    Pmax = UBound(VV) \ C
    If (UBound(VV) Mod C) <> 0 Then
        Pmax = Pmax + 1
    End If
    ReDim V2(1 To Pmax * 指定行, 1 To 元列数 * 指定列)
    
    i = 1: j = 1: P = 1: ii = 1
    Do While P <= Pmax And ii <= UBound(VV)
        Do While j <= 元列数 * 指定列 And ii <= UBound(VV)
            Do While i <= 指定行 And ii <= UBound(VV)
                For k = 0 To 元列数 - 1
                    V2((P - 1) * 指定行 + i, j + k) = VV(ii, 1 + k)
                Next
                i = i + 1
                ii = ii + 1
            Loop
            i = 1
            j = j + 元列数
        Loop
        j = 1
        P = P + 1
    Loop
    
    Set rngDest = Worksheets.Add.Range("A1")
    rngDest.Resize(UBound(V2), UBound(V2, 2)).Value = V2
End Sub
top

LoadPicturesForMsWord ― 画像ファイルの一括読込み&並べて表示のワード版、改ページにも対応済み
 画像読込み 画像縮小一覧表示 Word版 Word用 ※フォルダ選択とCsort(=コムソート)を使用する
Option Explicit
Option Compare Text

Sub LoadPictures()
    Dim Fld As String
    Dim Fname As String
    Dim Fnames As Variant
    Dim Fc As Integer
    Dim Pic As Shape
    Dim i As Integer
    
    '取り込み後の画像サイズ
    Const PicWcm As Single = 5.5
    Const PicHcm As Single = 8      '必ず横より縦の方を長く指定すること(横長画像は縦横入替えて設定される)
    Dim PicW As Single, PicH As Single
    
    '用紙の左と上余白&貼り付け有効幅と高さcm
    Const LMcm As Single = 1
    Const TMcm As Single = 1
    Const PWcm As Single = 19.5
    Const PHcm As Single = 28.2
    Dim LM As Single, TM As Single, PW As Single, PH As Single
    
    Const gap As Single = 1 '画像間スキマpoint
    Dim L As Single     '画像の貼付け位置左
    Dim T As Single     '画像の貼付け位置上
    Dim T1 As Single    '次行の画像貼付け位置上
    Dim R As Range
    
    Fld = フォルダ選択("画像フォルダ選択(*.jpg,*.jpeg)")
    If Fld = "" Then Exit Sub
    Fld = Fld & "\"
    
    'ファイル名取り込み&並べ替え
    Fc = 0
    Fname = Dir(Fld & "*.jp*")
    Do Until Fname = ""
        If LCase(Fname) Like "*.jpg" Or LCase(Fname) Like "*.jpeg" Then
            Fc = Fc + 1
            If Fc = 1 Then
                ReDim Fnames(1 To 1)
            Else
                ReDim Preserve Fnames(1 To Fc)
            End If
            Fnames(Fc) = Fname
        End If
        Fname = Dir()
    Loop
    If Fc = 0 Then
        MsgBox "対象ファイルがありません。", vbExclamation
        Exit Sub
    End If
    Fnames = Csort(Fnames)
    
    PicW = Application.CentimetersToPoints(PicWcm)
    PicH = Application.CentimetersToPoints(PicHcm)
    LM = Application.CentimetersToPoints(LMcm)
    TM = Application.CentimetersToPoints(TMcm)
    PW = Application.CentimetersToPoints(PWcm)
    PH = Application.CentimetersToPoints(PHcm)
    
    Application.ScreenUpdating = False
    
    With ActiveDocument.PageSetup
        .LeftMargin = LM
        .TopMargin = TM
        .RightMargin = .PageWidth - LM - PW
        .BottomMargin = .PageHeight - TM - PH
        .HeaderDistance = 0
        .FooterDistance = 0
    End With
    
    L = 0: T = 0: T1 = 0
    For i = 1 To Fc
        Fname = Fnames(i)
        Application.StatusBar = i & "/" & Fc
        
        Set R = ActiveDocument.Range
        R.SetRange R.End - 1, R.End

        Set Pic = ActiveDocument.Shapes.AddPicture(Fld & Fname, _
            LinkToFile:=False, SaveWithDocument:=True, Anchor:=R)
        With Pic
            '縮小(サイズオーバーしないように長い方を縮小する)
            .LockAspectRatio = msoTrue
            If .Height >= .Width Then
                '縦長画像の場合
                If .Width / .Height > PicW / PicH Then
                    .Width = PicW
                Else
                    .Height = PicH
                End If
            Else
                '横長画像の場合
                If .Width / .Height > PicH / PicW Then
                    .Width = PicH
                Else
                     .Height = PicW
               End If
            End If
            
            '位置調整
            If L + .Width > PW Then
                '次行
                L = 0
                T = T1
            End If
            If T + .Height > PH Then
                '次ページ
                
                '下記Cut&Pasteで.Width等が得られなくなるのでその前に実行
                L = 0
                L = L + .Width + gap
                T = 0
                T1 = T + .Height + gap
                
                '次ページの先頭へ移動、但し本当の移動は無理のようなのでCut&Paste
                .Select
                Selection.Cut
                次ページ追加
                Selection.Paste
                With Selection
                    .ShapeRange(1).Left = 0
                    .ShapeRange(1).Top = 0
                    .Collapse
                End With
            Else
                '同ページ
                .Left = L
                .Top = T
                L = L + .Width + gap
                If T + .Height + gap > T1 Then T1 = T + .Height + gap
            End If
        End With
    Next i
    
    Application.ScreenUpdating = True
End Sub

Sub 次ページ追加()
    Dim R As Range
    Set R = ActiveDocument.Range
    R.SetRange R.End, R.End
    With R
        .InsertBreak Type:=wdPageBreak
        .Select
    End With
End Sub
top

LoadPictures3 ― 指定レイアウトの位置に画像を貼り付ける、選択した画像を1ページに付き3枚貼り付ける例
 指定位置への図の挿入 指定位置への図の取り込み 指定フォーマットへの画像貼り付け
Sub LoadPictures3()
    '1枚目の貼り付け位置、2枚目以降の相対位置、改ページの行数は適宜修正のこと
    Dim Fnames As Variant
    Dim Fn As Variant
    Dim i As Integer
    Dim Pic As Picture
    Dim R As Range
    Dim Pc As Integer
    
    Fnames = Application.GetOpenFilename("図(*.jpg;*.gif),*.jpg;*.gif", MultiSelect:=True)
    If TypeName(Fnames) = "Boolean" Then Exit Sub
    
    Application.ScreenUpdating = False
    
    '一枚目の貼付け位置
    Set R = Range("A1")
    Pc = 0
    
    For i = 1 To UBound(Fnames)
        Set Pic = ActiveSheet.Pictures.Insert(Fnames(i))
        Select Case (i - 1) Mod 3 + 1
            Case 1
                Pc = Pc + 1
                If Pc >= 2 Then
                    ActiveSheet.HPageBreaks.Add R
                End If
                With R
                    Pic.Left = .Left
                    Pic.Top = .Top
                    Pic.Width = 300
                    Pic.Height = 200
                End With
            Case 2
                With R.Offset(15, 5)    '一枚目に対する二枚目の相対位置
                    Pic.Left = .Left
                    Pic.Top = .Top
                    Pic.Width = 200
                    Pic.Height = 100
                End With
            Case 3
                With R.Offset(25, 2)    '一枚目に対する三枚目の相対位置
                    Pic.Left = .Left
                    Pic.Top = .Top
                    Pic.Width = 150
                    Pic.Height = 300
                End With
                
                '次ページの相対位置
                Set R = R.Offset(50)
        End Select
    Next
    Application.ScreenUpdating = True
End Sub
top

LoadPictures2 ― 指定フォルダ中のすべての画像ファイルをシートに貼り付ける(複数行・列、改ページ付き)
 ※画像は指定した幅と高さ以内になるように自動縮小される
Sub LoadPictures2()
    Dim Fld As String
    Dim Fname As String
    Dim Pic As Picture
    
    Const PicWcm As Single = 8      '幅
    Const PicHcm As Single = 9      '高さ(必ず幅より高さの方を長く指定すること)
    Dim PicW As Long, PicH As Long
    
    Const LMcm As Single = 1    '左右余白
    Const TMcm As Single = 1    '上下余白
    Dim LM As Long, TM As Long, PW As Long, PH As Long
    
    Const Gap As Long = 2   '画像間隙間(ポイント)
    Dim L As Long
    Dim T As Long
    Dim T1 As Long  '画像次行トップ位置
    
    Dim C As Integer    '画像行数カウント
    Dim rngTemp As Range
    
    Fld = フォルダ選択(Title:="画像フォルダ選択(*.jpg,*.jpeg)")
    If Fld = "" Then Exit Sub
    Fld = Fld & "\"
    
    PicW = CLng(Application.CentimetersToPoints(PicWcm))
    PicH = CLng(Application.CentimetersToPoints(PicHcm))
    
    LM = CLng(Application.CentimetersToPoints(LMcm))
    TM = CLng(Application.CentimetersToPoints(TMcm))
    PW = CLng(Application.CentimetersToPoints(21 - LMcm * 2))   'A4たて基準
    PH = CLng(Application.CentimetersToPoints(30 - TMcm * 2))   ' 〃
    
    Application.ScreenUpdating = False
    
    Workbooks.Add
    With ActiveCell.Worksheet.PageSetup
        .LeftMargin = LM
        .RightMargin = LM
        .TopMargin = TM
        .BottomMargin = TM
        .HeaderMargin = TM
        .FooterMargin = TM
    End With
    
    C = 1
    L = 0: T = 0
    T1 = 0
    Fname = Dir(Fld & "*.jp*")
    Do Until Fname = ""
        If LCase(Fname) Like "*.jpg" Or LCase(Fname) Like "*.jpeg" Then
            Set Pic = ActiveSheet.Pictures.Insert(Fld & Fname)
            With Pic.ShapeRange(1)
                '縮小
                .LockAspectRatio = msoTrue
                If .Height >= .Width Then
                    If .Width / .Height > PicW / PicH Then
                        .Width = PicW
                    Else
                        .Height = PicH
                    End If
                Else
                    If .Width / .Height > PicH / PicW Then
                        .Width = PicH
                    Else
                         .Height = PicW
                   End If
                End If
                
                'これから貼り付ける画像の幅がはみ出るようなら次行に移る
                If L + Gap + .Width > LM + PW Then
                    L = 0
                    T = T1
                    C = C + 1
                End If
                
                '画像行数3行毎に改ページを挿入する
                If C > 3 Then
                    ActiveSheet.HPageBreaks.Add before:=rngTemp
                    L = 0
                    T = rngTemp.Top + Gap
                    T1 = T
                    C = 1
                End If
                
                .Left = L
                .Top = T
                
                L = L + Gap + .Width
                If T + Gap + .Height > T1 Then
                    T1 = T + Gap + .Height
                    Set rngTemp = .BottomRightCell.Offset(1)
                End If
                
            End With
        End If
        Fname = Dir()
    Loop
    
    Application.ScreenUpdating = True
End Sub

'選択したフォルダのフルパスを返す、キャンセル又はエラーなら""を返す
Public Function フォルダ選択(Optional Title As String = "フォルダを選択して下さい。", _
        Optional RootFolder As Variant) As String
    '参照設定するなら、Microsoft Shell Controls And Automationに
    Dim Shl As Object   'Shell32.Shell
    Dim Fld As Object   'Folder
    Dim strFld As String
    
    Set Shl = CreateObject("Shell.Application")
    '1:コントロールパネルなどの余分なもの非表示  512:新規フォルダ作成ボタン非表示
    If IsMissing(RootFolder) Then
        Set Fld = Shl.BrowseForFolder(0, Title, 1 + 512)
    Else
        Set Fld = Shl.BrowseForFolder(0, Title, 1 + 512, RootFolder)
    End If
    
    strFld = ""
    If Not Fld Is Nothing Then
        On Error Resume Next
        strFld = Fld.Self.Path
        If strFld = "" Then
            strFld = Fld.Items.Item.Path
        End If
        On Error GoTo 0
    End If
    
    If InStr(strFld, "\") = 0 Then strFld = ""
    
    フォルダ選択 = strFld
    
    Set Fld = Nothing
    Set Shl = Nothing
End Function
top

LoadPictures ― 指定フォルダ中のすべての画像ファイルをシート上に上から下に順に貼り付ける
 画像ファイル 一括貼り付け ピクチャー 画像一括読み込み
Sub LoadPictures()
    Dim myPic As Picture
    Dim myPath As String
    Dim Fname As String
    Dim myCell As Range
    
    myPath = ThisWorkbook.Path & "\"
    Set myCell = Range("A1")
    
    Fname = Dir(myPath & "*.jpeg")
    Do Until Fname = ""
        Set myPic = myCell.Worksheet.Pictures.Insert(myPath & Fname)
        With myPic
            .Left = myCell.Left
            .Top = myCell.Top
        End With
        
        Set myCell = myCell.Worksheet.Cells(myPic.BottomRightCell.Row + 1, 1)
        Fname = Dir()
    Loop
End Sub
top

画像貼付け ― ワークシートに指定した大きさ(10cm×10cm)で画像を貼り付ける
 画像貼付け ピクチャー 画像ファイル Picture
Sub 画像貼付け()
    Dim Fname As Variant
    Dim L As Single
    Dim T As Single
    Dim W As Single
    Dim H As Single
    
    W = Application.CentimetersToPoints(10)
    H = Application.CentimetersToPoints(10)
    
    Fname = Application.GetOpenFilename("ピクチャー(*.jpg),*.jpg")
    If Fname = False Then Exit Sub
    
    With ActiveCell
        .Worksheet.Shapes.AddPicture Fname, msoFalse, msoTrue, .Left, .Top, W, H
    End With
End Sub
top

UserForm上で右クリックで貼り付け ― UserForm上のTextBox、ComboBoxに右クリックメニューを追加し、カット・コピー・貼り付け可能にする
 ユーザーフォーム上でコピーペースト テキストボックス コンボボックス ※UserForm上に適当な数のTextBoxとComboBoxを配置し、ShowForm実行で動作確認できる
===== フォームモジュール(UserForm1) =====
Option Explicit

'クラスのインスタンス保持用
Private colText As Collection

Private Sub UserForm_Initialize()
    Dim myCopy As cCopyPaste
    Dim myText As MSForms.Control
    
    Set colText = New Collection
    
    'TextBoxとComboBoxに対して設定する
    For Each myText In Me.Controls
        If TypeOf myText Is MSForms.TextBox Then
            Set myCopy = New cCopyPaste
            Set myCopy.Text = myText
            colText.Add myCopy
        ElseIf TypeOf myText Is MSForms.ComboBox Then
            Set myCopy = New cCopyPaste
            Set myCopy.Comb = myText
            colText.Add myCopy
        End If
    Next
End Sub

Private Sub UserForm_Terminate()
    Dim i As Integer
    For i = 1 To colText.Count
        colText.Remove 1
    Next
    Set colText = Nothing
End Sub

===== 標準モジュール(Module1) =====
Option Explicit
'「UserForm1」は適宜変更のこと

Sub ShowForm()
    UserForm1.Show
End Sub

'Functionにしたのはマクロリストに表示しないため。以下同様。
Public Function 切り取り()
    UserForm1.ActiveControl.Cut
End Function

Public Function コピー()
    UserForm1.ActiveControl.Copy
End Function

Public Function 貼り付け()
    UserForm1.ActiveControl.Paste
End Function

===== クラスモジュール(cCopyPaste) =====
Option Explicit

'コピー&ペースト用プロシージャのプロジェクト名とモジュール名。ここは適宜変更のこと。
Private Const Project As String = "myProject.Module1"

Public WithEvents Text As MSForms.TextBox
Public WithEvents Comb As MSForms.ComboBox

'ComboBoxがリスト表示している時はショートカットメニューを表示しないようにするため
Private flgDrop As Boolean

Private Sub Class_Terminate()
    Set Text = Nothing
    Set Comb = Nothing
End Sub

Private Sub Comb_DropButtonClick()
    'リスト表示中はTrueとなる
    flgDrop = Not flgDrop
End Sub

Private Sub Comb_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If flgDrop Then Exit Sub    'リスト表示中は無効にする
    MouseUp Button, Comb
End Sub

Private Sub Text_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MouseUp Button, Text
End Sub

Private Sub MouseUp(ByVal Button As Integer, Ctrl As MSForms.Control)
    If Button <> 2 Then Exit Sub
    Dim Cb As CommandBar
    Dim Btn As CommandBarButton
    
    Set Cb = Application.CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
    
    Set Btn = Cb.Controls.Add(Type:=msoControlButton)
    With Btn
        .Caption = "切り取り"
        .OnAction = Project & ".切り取り"
        'テキスト未選択時は無効にする
        If Ctrl.SelText = "" Then
            .Enabled = False
        End If
    End With
    
    Set Btn = Cb.Controls.Add(Type:=msoControlButton)
    With Btn
        .Caption = "コピー"
        .OnAction = Project & ".コピー"
        'テキスト未選択時は無効にする
        If Ctrl.SelText = "" Then
            .Enabled = False
        End If
    End With
    
    Set Btn = Cb.Controls.Add(Type:=msoControlButton)
    With Btn
        .Caption = "貼り付け"
        .OnAction = Project & ".貼り付け"
        'クリップボードに文字列が無い時は無効にする
        If Not Ctrl.CanPaste Then
            .Enabled = False
        End If
    End With
    
    Cb.ShowPopup
    Cb.Delete
End Sub
top

グループ毎に新規シートへ ― 同じ値のグループ毎に新規シートへコピー
 グループ毎に別シートへコピー グループをシートにコピー
Sub グループ毎に新規シートへ()
    'グループ基準列で並べ替え済であること
    Dim RR As Range
    Dim myTitle As Range
    Dim myCol As Range
    Dim S As Long, E As Long
    Dim i As Long
    Dim maxRow As Long
    Dim V As Variant
    Dim rngDest As Range
    
    '元データ範囲、タイトル行、グループ基準列取得
    Set RR = Range("A1").CurrentRegion
    Set myTitle = RR.Rows(1)
    Set RR = RR.Offset(1).Resize(RR.Rows.Count - 1)
    Set myCol = RR.Columns(RR.Columns.Count)
    
    maxRow = myCol.Rows.Count
    
    'グループの最初と最後の行番号を見つけながら処理
    Do
        S = E + 1
        V = myCol.Cells(S).Value
        
        i = S
        Do
            i = i + 1
        Loop Until myCol.Cells(i).Value <> V Or i > maxRow
        E = i - 1
        
        '新規シートを追加して、タイトルと中身を書き出し、シート名をグループの値とする
        Set rngDest = Worksheets.Add(after:=Sheets(Sheets.Count)).Range("A1")
        myTitle.Copy rngDest
        RR.Rows(S & ":" & E).Copy rngDest.Offset(1)
        rngDest.Worksheet.Name = V
        
    Loop Until i > maxRow
    
    Set RR = Nothing
    Set myTitle = Nothing
    Set myCol = Nothing
    Set rngDest = Nothing
End Sub
top

オートフィルタに罫線 ― フィルタを掛けた後の状態に対して同じ値の範囲毎に罫線を引く
 オートフィルタ 同値毎に罫線
Sub Ksen()
    Dim Coll As Collection
    Dim RR As Range
    Dim Are As Range
    Dim R As Range
    Dim i As Long
    Const N As Integer = 5  'オートフィルタ範囲中の値比較対象列
    
    Set Coll = New Collection
    
    Set RR = ActiveCell.Worksheet.AutoFilter.Range
    RR.Borders(xlInsideHorizontal).LineStyle = xlNone
    Set RR = RR.SpecialCells(xlCellTypeVisible)
    
    For Each Are In RR.Areas
        For Each R In Are.Columns(N).Cells
            Coll.Add R
        Next
    Next
    
    For i = 1 To Coll.Count - 1
        If Coll(i).Value <> Coll(i + 1).Value Then
            With Intersect(Coll(i).EntireRow, RR)
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
            End With
        End If
    Next
    
    Set Coll = Nothing
End Sub
top

最新ファイル名取得 ― 指定フォルダ中の指定ファイル(ワイルドカード名、配列可)から最新のファイル名を返す、無ければ""
 最新のファイル 最新更新日 最終更新日 最新作成日
Sub CallTest_GetNewFileName()
    Dim F As String
    F = GetNewFileName(ThisWorkbook.Path, Array("*.txt", "*.csv", "*.doc"))
    MsgBox F
End Sub

'指定フォルダ中の指定ファイル(ワイルドカード名、配列可)から最新のファイル名を返す、無ければ""
Private Function GetNewFileName(TargetPath As String, Fnames As Variant) As String
    Dim Fso As Object   'FileSystemObject
    Dim Fl As Object    'Folder
    Dim F As Object     'File
    Dim myFile As Object    'File
    Dim myDate As Date      '更新日時の最新値
    
    Dim Flg As Boolean  'Fnamesに一致したかどうかのフラグ
    Dim Fn As Variant
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Fl = Fso.GetFolder(TargetPath)
    
    For Each F In Fl.Files
        '指定ファイルか確認
        Flg = False
        '配列で指定されている時
        If IsArray(Fnames) Then
            For Each Fn In Fnames
                If LCase(F.Name) Like LCase(Fn) Then
                    Flg = True
                    Exit For
                End If
            Next
        Else
        '単一指定の時
            If LCase(F.Name) Like LCase(Fnames) Then
                Flg = True
            End If
        End If
        
        '更新日が最新のファイルを抽出(作成日なら、.DateCreated)
        If Flg Then
            If myFile Is Nothing Then
                Set myFile = F
                myDate = myFile.DateLastModified
            ElseIf F.DateLastModified > myDate Then
                Set myFile = F
                myDate = myFile.DateLastModified
            End If
        End If
    Next
    
    If Not myFile Is Nothing Then
        GetNewFileName = myFile.Name
    Else
        GetNewFileName = ""
    End If
    
    Set myFile = Nothing
    Set F = Nothing
    Set Fl = Nothing
    Set Fso = Nothing
End Function
top

フォルダ内のブックをループ処理 ― ダイアログでフォルダを選択し、フォルダ内のファイルに対してループ処理する雛形
 フォルダ選択 ループ処理 全ブック 繰り返し処理 順次処理
Sub LoopFiles()
    Dim BF As Object
    Dim Fp As String
    Dim Fso As Object   'FileSystemObject
    Dim Fld As Object   'Folder
    Dim Fl As Object    'File
    Dim Wb As Workbook
    
    Set BF = CreateObject("Shell.Application"). _
        BrowseForFolder(0, "フォルダを選択してください。", 513)
    If BF Is Nothing Then Exit Sub
    
    On Error Resume Next
    Fp = BF.Self.Path
    If Fp = "" Then
        Fp = BF.Items.Item.Path
    End If
    On Error GoTo 0

    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Fld = Fso.GetFolder(Fp)
    
    For Each Fl In Fld.Files
        If LCase(Fl.Name) = LCase(ThisWorkbook.Name) Then
        ElseIf LCase(Fl.Name) Like "*.xls" Then
            
            '処理
            Debug.Print Fl.Path
            
'            Set Wb = Workbooks.Open(Fl.Path)
'            'オープンしたブックに対する処理
'            Wb.Close
        End If
    Next
    
    Set BF = Nothing
    Set Fso = Nothing
    Set Fld = Nothing
    Set Fl = Nothing
    Set Wb = Nothing
End Sub
top

選択したセルの行で、二列め以降を選択する ― Rangeオブジェクトを使用した効率的なセル範囲指定
 二列目以降 2列め以降 2列目以降 ※二列め以降にするために、始めにUsedRangeの二列め以降への参照を取得しておくのがミソ
仕様
下記「あ」「い」「選」は各々セルで、このシートの現在の使用範囲
「選」は、Ctrlを押しながら選択したセル
実行すると、二列め以降の「い」と「選」の部分が選択される

あああああああ
あい選いいいい
あああああああ
あ選いいいいい
あいいい選いい
あああああああ

Sub mySelect()
    Dim Ur As Range
    Dim RR As Range
    
    Set RR = Selection
    Set Ur = RR.Worksheet.UsedRange
    Set Ur = Intersect(Ur, Ur.Offset(, 1))
    
    Set RR = RR.EntireRow
    Set RR = Intersect(RR, Ur)
    
    RR.Select
End Sub
top

結合セル範囲に対するループ処理 ― A列の結合セルに対応してB列もセル結合する
 セルの結合 隣接した列もセルを結合する 隣接列のセル結合 ※データ処理する場合、セル結合は極力避けた方が良い
Sub セル結合()
    Dim R As Range
    Set R = Range("A1")
    Do Until R.Value = ""
        Application.DisplayAlerts = False
        R.MergeArea.Resize(, 2).Columns(2).Merge
        Application.DisplayAlerts = True
        Set R = R.Offset(1)
    Loop
End Sub
top

同値セル結合 ― 同値のセルを結合する、A列縦方向の例
 セルの結合 結合セル マージ ※最後のセルがMerge済みだとこける。
Sub 同値セル結合()
    Dim S As Range
    Dim E As Range
    
    Set S = Range("A1")
    Set E = S
    
    Do Until S.Value = ""
        Set E = E.Offset(1)
        If E.Value = E.Offset(-1).Value Then
        Else
            Application.DisplayAlerts = False
            Range(S, E.Offset(-1)).Merge
            Application.DisplayAlerts = True
            Set S = E
        End If
    Loop
End Sub
top

セル結合解除 ― 選択範囲中の結合セルの結合を解除し、同値で埋め、見た目をほぼ結合セルに見せかける
 擬似セル結合 擬似結合 結合解除 MargeArea マージエリア
Sub セル結合解除()
    Dim Dic As Object
    Dim RR As Range
    Dim R As Range
    Dim M As Range
    Dim V As Variant
    
    Set RR = Selection
    Set RR = Intersect(RR, RR.Worksheet.UsedRange)
    
    Set Dic = CreateObject("Scripting.Dictionary")
    
    '結合セルを抽出する
    For Each R In RR.Cells
        Set M = R.MergeArea
        If M.Address <> R.Address Then
            Set Dic.Item(M.Address) = M
        End If
    Next
    
    For Each V In Dic.Keys
        Set M = Dic.Item(V)
        結合解除 M
    Next
    
    Set M = Nothing
    Set R = Nothing
    Set RR = Nothing
    Set Dic = Nothing
End Sub

Private Sub 結合解除(M As Range)
    With M
        '結合解除
        .UnMerge
        '同値で埋める
        .Value = .Cells(1).Value
        '文字色(中央のみ黒、あとは白)
        .Font.Color = vbWhite
        .Cells((.Cells.Count - 1) \ 2 + 1).Font.ColorIndex = xlAutomatic
        'セルを白で塗りつぶし
        .Interior.Color = vbWhite
        .Interior.Pattern = xlSolid
        '枠を25%の灰色に
        .BorderAround xlContinuous, xlThin, 15
    End With
End Sub
top

改行キーで任意セル間移動 ― 設定した任意のセル範囲の中を改行キーだけで移動する
 改行キーで移動 設定範囲内を改行キー移動 入力域を改行で移動 ※その範囲を選択状態に保つことで実現
===== シートモジュール =====
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    Dim R As Range
    Set R = Target
    With Range("A2,A3,C2,D4")
        If Intersect(.Cells, R) Is Nothing Then Exit Sub
        .Select
        R.Activate
    End With
End Sub
top

ClipBoardToTextFile ― クリップボードの内容をテキストファイルに書き出す
 クリップボード テキストファイル ClipBoard TextFile データオブジェクト
Sub test()
    ActiveSheet.UsedRange.Copy
    ClipBoardToTextFile ThisWorkbook.Path & "\test.txt"
    Application.CutCopyMode = False
End Sub

'Microsoft Forms x.x Object Library と
'Microsoft Scripting Runtime に参照設定要
Private Sub ClipBoardToTextFile(Pathh As String)
    'クリップボードの内容をテキストファイルに書き出す
    Dim Doj As DataObject
    Dim V As String
    Dim Fso As FileSystemObject
    Dim Ts As TextStream
    
    Set Doj = New DataObject
    With Doj
        .GetFromClipboard
        On Error Resume Next
        V = .GetText
        On Error GoTo 0
    End With
    
    If V <> "" Then
        Set Fso = New FileSystemObject
        Set Ts = Fso.OpenTextFile(Pathh, 2, True)
        Ts.Write V
        Ts.Close
    End If
    
    Set Doj = Nothing
    Set Ts = Nothing
    Set Fso = Nothing
End Sub
top

ファイル一覧作成簡易版 ― 「ファイル一覧作成」の心臓部を、コピペで実行できるコードに整えて掲載
 ファイル階層表示 フォルダ階層表示 ファイル名にハイパーリンク
Option Explicit

Private myRow As Long
Private mySheet As Worksheet    '出力先シート

'何階層めまで対象とするか(指定フォルダを1階層めとする。設定は2以上。0なら全階層が対象。)
Const max階層 As Long = 0

Const 更新日指定 As Boolean = True
Const サイズ指定 As Boolean = False
Const 連結文字 As String = " --- "
Const HyperLink指定 As Boolean = True
Const ワイルドカード As String = "*.xls"

Private Sub 実行()
    Dim path始点 As String
    Dim myMsg As String
    
    path始点 = "D:\My Documents"
    
    'ドライブのルートの時は\をカットする
    If path始点 Like "?:\" Then
        path始点 = Left$(path始点, 2)
    End If
    
    Application.ScreenUpdating = False
    
    Set mySheet = Application.Workbooks.Add.Worksheets(1)
    
    myRow = 1
    GetFileLists FolderPath:=path始点, myColumn:=1
    
    Application.ScreenUpdating = True
    Set mySheet = Nothing
    
End Sub

Private Sub GetFileLists(FolderPath As String, myColumn As Long _
        , Optional ParentFolder As Range = Nothing)
    'フォルダ、直下のファイル、サブフォルダを表示する。(FolderPathの最後に\は無し)
    '1つ設定したら行はカウントアップする。
    '親フォルダがある時は、フォルダの左セルから親フォルダの下セルへ、左と下に罫線を引く
    '下位フォルダがある場合は、パスにフォルダ名を+し、列を+1して再帰呼び出しをする。
    Dim myDirs As Variant
    Dim 表示名 As String
    Dim Folders() As String     'ワイルドカードにマッチしたフォルダ名のリスト
    Dim cF As Integer           'フォルダ名カウント
    Dim strTemp As String
    Dim i As Integer
    Dim rngFolder As Range      '現フォルダ
    Dim rngTemp As Range
    
    If myColumn = 1 Then
        表示名 = FolderPath
    Else
        myDirs = Split(FolderPath, "\")
        表示名 = myDirs(UBound(myDirs))
    End If
    
    Set rngFolder = mySheet.Cells(myRow, myColumn)
    With rngFolder
        .Value = 表示名
        .Interior.Color = vbYellow
        If HyperLink指定 Then
            mySheet.Hyperlinks.Add Anchor:=.Cells(1), Address:=FolderPath
        End If
    End With
    
    '親フォルダがある時は
    If Not ParentFolder Is Nothing Then
        '親フォルダの下から現フォルダの左まで
        Set rngTemp = mySheet.Range(ParentFolder.Offset(1, 0) _
            , rngFolder.Offset(0, -1))
        With rngTemp
            '左と
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            '下の罫線を引く
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        End With
    End If
    myRow = myRow + 1
    
    'ファイルリスト表示
    On Error GoTo Trap
    strTemp = Dir(FolderPath & "\" & ワイルドカード, vbNormal)
    On Error GoTo 0
    Do While strTemp <> ""
        If (GetAttr(FolderPath & "\" & strTemp) And vbNormal) = vbNormal Then
            表示名 = strTemp
            If 更新日指定 Then
                表示名 = 表示名 & 連結文字 & FileDateTime(FolderPath & "\" & strTemp)
            End If
            If サイズ指定 Then
                表示名 = 表示名 & 連結文字 & Format(FileLen(FolderPath & "\" & strTemp), "0,0")
            End If
            With mySheet.Cells(myRow, myColumn + 1)
                .Value = 表示名
                If HyperLink指定 Then
                    mySheet.Hyperlinks.Add Anchor:=.Cells(1), _
                        Address:=FolderPath & "\" & strTemp
                End If
            End With
            myRow = myRow + 1
        End If
        strTemp = Dir()
    Loop
    
    '下位フォルダを取り出す
    cF = 0
    strTemp = Dir(FolderPath & "\*.*", vbDirectory)
    Do While strTemp <> ""
        If strTemp = "." Or strTemp = ".." Then
            'nop
        ElseIf (GetAttr(FolderPath & "\" & strTemp) And vbDirectory) = vbDirectory Then
            'フォルダ
            cF = cF + 1
            If cF = 1 Then
                ReDim Folders(1 To cF)
            Else
                ReDim Preserve Folders(1 To cF)
            End If
            Folders(cF) = strTemp
        End If
        strTemp = Dir()
    Loop
    
    Set rngTemp = Nothing
    
    '階層指定なし又は列<指定階層なら
    If max階層 < 2 Or myColumn + 1 < max階層 Then
        '下位フォルダがある場合は、パスにフォルダ名を+し、列を+1して再帰呼び出しをする。
        For i = 1 To cF
            GetFileLists FolderPath & "\" & Folders(i), myColumn + 1, rngFolder
        Next
    Else
        '指定の最終階層なら
        For i = 1 To cF
            Set rngFolder = mySheet.Cells(myRow, myColumn + 1)
            With rngFolder
                .Value = Folders(i)
                .Interior.Color = RGB(255, 127, 0)  'オレンジ色
                If HyperLink指定 Then
                    mySheet.Hyperlinks.Add Anchor:=.Cells(1), _
                        Address:=FolderPath & "\" & Folders(i)
                End If
            End With
            myRow = myRow + 1
        Next
    End If

    Erase Folders
    Exit Sub
    
Trap:
    MsgBox "ワイルドカードの指定が正しくありません。", vbCritical
    On Error GoTo 0
    End
End Sub
top

可視セルへ貼り付け ― クリップボードの値を可視セル範囲へ貼り付ける。(フィルタリングした範囲への貼り付け)
 可視セルへの貼り付け 可視セルへの貼付け フィルタ後へ貼り付け
Sub 可視セルへ貼り付け()
    'Microsoft Forms 2.0 Object Library に参照設定要
    Dim Dobj As DataObject
    Dim V As Variant    'クリップボードのデータ全体
    Dim A As Variant    'その内の一行
    Dim rngDest As Range
    Dim R As Range
    Dim i As Integer
    
    With ActiveCell.Worksheet.AutoFilter.Range
        Set rngDest = .Columns(.Columns.Count + 1)  'とりあえず、貼り付け先はオートフィルタ範囲の右列
        Set rngDest = Intersect(rngDest, rngDest.Offset(1))
        Set rngDest = rngDest.SpecialCells(xlCellTypeVisible)   '最後に可視セルを取得するのがみそ
    End With
    
    Set Dobj = New DataObject
    With Dobj
        .GetFromClipboard
        On Error Resume Next
        V = .GetText
        On Error GoTo 0
    End With
    
    If Not IsEmpty(V) Then    'クリップボードからテキストが取得できた時のみ実行
        V = Split(CStr(V), vbCrLf)
        i = 0
        For Each R In rngDest.Cells
            A = Split(CStr(V(i)), vbTab)
            R.Resize(, UBound(A) + 1).Value = A
            i = i + 1
            If i > UBound(V) Then Exit For
        Next
    End If
    
    Set Dobj = Nothing
    Set rngDest = Nothing
    Set R = Nothing
End Sub
top

空データの凡例削除 ― 系列の値が全て空の凡例を非表示にする
 空凡例削除 空の系列の判例削除 非表示 ※棒グラフと散布図ではやり方が違う
Sub 空白凡例削除()
    '棒グラフ用
    Dim V As Variant
    Dim i As Integer
    
    With ActiveSheet.ChartObjects(1).Chart
        On Error Resume Next
        .Legend.Delete
        .HasLegend = True
        On Error GoTo 0
        
        For i = .SeriesCollection.Count To 1 Step -1
            V = .SeriesCollection(i).Values
            If 空白(V) Then
                .Legend.LegendEntries(i).Delete
            End If
        Next
    End With
End Sub

Private Function 空白(V As Variant) As Boolean
    Dim i As Integer
    Dim Flg As Boolean
    Flg = True
    For i = LBound(V) To UBound(V)
        If V(i) <> "" Then
            Flg = False
            Exit For
        End If
    Next
    空白 = Flg
End Function

Sub 空白凡例削除2()
    '散布図用
    Dim V As Variant
    Dim i As Integer
    
    With ActiveSheet.ChartObjects(1).Chart
        On Error Resume Next
        .Legend.Delete
        .HasLegend = True
        On Error GoTo 0
        
        For i = .SeriesCollection.Count To 1 Step -1
            On Error Resume Next
            V = .SeriesCollection(i).Values
            If Err.Number <> 0 Then
                .Legend.LegendEntries(i).Delete
            End If
            On Error GoTo 0
        Next
    End With
End Sub
top

コードからのみ終了可 ― ユーザ操作による終了(既存の閉じるメニューや「×」ボタン)を不許可とし、コードからのみブックを閉じることを許可する
 コードでのみ終了 ユーザ操作不可 ×不許可
===== ThisWorkbookモジュール =====
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Not CloseFlag Then
        Cancel = True
        Exit Sub
    End If
End Sub

===== 標準モジュール =====
Public CloseFlag As Boolean

Sub myClose()
    CloseFlag = True
    ThisWorkbook.Close
End Sub
top

Enterキーで移動2 ― ワークシート内の決められたセルのみをEnterキーで移動(ブック全体で、シート毎の設定により移動するように拡張)
 固定セルをEnterキーで移動 改行キーで移動 Enterで移動
===== ThisWorkbook モジュール =====
Option Explicit

Private myCells As Variant
Private CellsCount As Integer

Private Sub Workbook_Open()
    Workbook_SheetActivate ActiveSheet
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    'シート毎の設定
    Select Case Sh.Name
        Case "Sheet1", "Sheet2"
            セット
            myCells = Array("A1", "C1", "E1", "F1")
        Case "Sheet3"
            セット
            myCells = Array("B2", "D2", "G2", "H2")
        Case Else
            '対象外シート
            リセット
            Exit Sub
    End Select
    
    Sh.Range("A1").Select
    CellsCount = UBound(myCells)
    
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    リセット
End Sub

Private Sub セット()
    Application.OnKey "{ENTER}", "ThisWorkbook.Enterで移動"
    Application.OnKey "~", "ThisWorkbook.Enterで移動"
End Sub
Private Sub リセット()
    Application.OnKey "{ENTER}"
    Application.OnKey "~"
End Sub

Private Sub Enterで移動()
    Dim i As Integer
    Dim myAddress As String
    Dim Flg As Boolean
    
    With ActiveCell
        myAddress = .Address(0, 0, xlA1, 0)
        For i = 0 To CellsCount
            If myCells(i) = myAddress Then
                Range(myCells((i + 1) Mod (CellsCount + 1))).Activate
                Flg = True
                Exit For
            End If
        Next
    End With
    
    '入力対象外の範囲の時
    If Not Flg Then
        If Application.MoveAfterReturn Then
            Select Case Application.MoveAfterReturnDirection
                Case xlDown
                    ActiveCell.Offset(1).Activate
                Case xlToRight
                    ActiveCell.Offset(, 1).Activate
                Case xlUp
                    ActiveCell.Offset(-1).Activate
                Case xlToLeft
                    ActiveCell.Offset(, -1).Activate
            End Select
        End If
    End If
End Sub
top

Enterキーで移動 ― ワークシート内の決められたセルのみをEnterキーで移動する
 固定セルをEnterキーで移動 改行キーで移動 Enterで移動
Sub セット()
    Application.OnKey "{ENTER}", "Enterで移動"
    Application.OnKey "~", "Enterで移動"
End Sub

Sub リセット()
    Application.OnKey "{ENTER}"
    Application.OnKey "~"
End Sub

Sub Enterで移動()
    Dim myCells As Variant
    Dim C As Integer
    Dim i As Integer
    Dim myAddress As String
    Dim Flg As Boolean
    
    myCells = Array("A1", "C1", "D1", "G1", "A2", "A3", "C2")
    C = UBound(myCells)
    
    With ActiveCell
        myAddress = .Address(0, 0, xlA1, 0)
        For i = 0 To C
            If myCells(i) = myAddress Then
                Range(myCells((i + 1) Mod (C + 1))).Activate
                Flg = True
                Exit For
            End If
        Next
    End With
        
    '入力対象外の範囲の時
    If Not Flg Then
        If Application.MoveAfterReturn Then
            On Error Resume Next
            
            Select Case Application.MoveAfterReturnDirection
                Case xlDown
                    ActiveCell.Offset(1).Activate
                Case xlToRight
                    ActiveCell.Offset(, 1).Activate
                Case xlUp
                    ActiveCell.Offset(-1).Activate
                Case xlToLeft
                    ActiveCell.Offset(, -1).Activate
            End Select
            
            On Error GoTo 0
        End If
    End If
End Sub
top

256列を超えるCSVの読み込み ― 横長のCSVファイルを複数の既存シートに分割して読み込む
 横長CSVファイルの読み込み 257項目以上 分割読み込み ※新規ブックに必要な数のシートを予め確保しておくこと
Sub ReadLongCSV()
    '256を超える項目数のCSVファイルを複数のシート(既存)に分割して読み込む
    Dim myPath As String
    Dim N As Integer
    Dim Ld As String    'LineData
    Dim Lc As Long      'LineCounter
    Dim V As Variant    '分割データ
    Dim A As Variant    '一シート分のデータ
    Dim i As Integer, j As Integer
    Dim Sc As Integer   'SheetCounter
    
    myPath = ThisWorkbook.Path & "\test.csv"
    N = FreeFile
    Open myPath For Input As #N
    Do Until EOF(N)
        Line Input #N, Ld
        Lc = Lc + 1
        V = Split(Ld, ",")
        ReDim A(0 To 255)
        i = 0: j = 0: Sc = 0
        Do Until i > UBound(V)
            A(j) = V(i)
            If j = 255 Or i = UBound(V) Then
                Sc = Sc + 1
                Worksheets(Sc).Cells(Lc, 1).Resize(, j + 1).Value = A
                ReDim A(0 To 255)
                j = 0
            Else
                j = j + 1
            End If
            i = i + 1
        Loop
    Loop
    Close #N
End Sub

Sub CreateTestData()
    Dim myPath As String
    Dim N As Integer
    Dim i As Integer
    Dim j As Integer
    
    myPath = ThisWorkbook.Path & "\test.csv"
    N = FreeFile
    Open myPath For Output As #N
    For i = 1 To 100
        Print #N, 1;
        For j = 2 To 700
            Print #N, ","; j;
        Next: Print #N, ""
    Next
    Close #N
End Sub
top

コントロールツールのコントロールの操作 ― ワークシート上のコントロールツールボックスのコントロールを操作する例
 ワークシート上のコントロール ※ワークシート上では、コントロールツールボックスのコントロールはなるべく使わない方が良い、使うならフォームツールバーのコントロールの方が「安定」が良いのでお勧め
Sub コントロールツールのコントロール()   'Shapeからアクセスしているがその必要は無さそう、下記2の方がスマート
    Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes
        With Shp
            If .Type = msoOLEControlObject Then
                With .OLEFormat
                    If .ProgId = "Forms.ComboBox.1" Then
                        .Object.Object.AddItem "全て"   ' .ObjectでOLEObject、さらに.ObjectでComboBoxへの参照を取得している
                    End If
                End With
            End If
        End With
    Next
    Set Shp = Nothing
End Sub

Sub コントロールツールのコントロール2()
    Dim Obj As OLEObject
    For Each Obj In ActiveSheet.OLEObjects
        With Obj
            If .ProgId = "Forms.ComboBox.1" Then
                .Object.AddItem "全て"    '.ObjectでComboBoxへの参照を取得している
            End If
        End With
    Next
    Set Obj = Nothing
End Sub
top

Excel97用Join関数 ― 予め必要分の長さの文字列を確保し、Mid$ステートメントで置き換えることで高速化
 文字結合 文字連結 Split Mid$ステートメント
Sub test()
    Const N As Long = 10000
    Dim A(1 To N) As String
    Dim i As Long
    Dim T As Single
    Dim V As String
    
    For i = 1 To N
        A(i) = CStr(i)
    Next
    
    T = Timer
    V = Join97(A, ",")
    Debug.Print Timer - T
    
    Debug.Print V
End Sub

Public Function Join97(List As Variant, Optional Delimiter As String = " ") As String
    Dim L As Long, U As Long
    Dim Ret As String
    Dim i As Long
    Dim Ld As Long
    Dim Tlen As Long
    Dim j As Long
    Dim LL As Long
    
    L = LBound(List)
    U = UBound(List)
    Ld = Len(Delimiter)
    
    'デリミタを含めたトータル長さ
    Tlen = Len(List(L))
    For i = L + 1 To U
        Tlen = Tlen + Ld + Len(List(i))
    Next
    
    '予め必要分の長さの文字列を確保
    Ret = String$(Tlen, " ")
    
    If Delimiter = " " Or Delimiter = "" Then
    'デリミタがスペースか "" なら置換え必要無し
        j = 1   '次の文字の置き換えポイント
        If List(L) <> "" Then
            LL = Len(List(L))
            Mid$(Ret, j, LL) = List(L)
            j = j + LL
        End If
        
        For i = L + 1 To U
            j = j + Ld
            If List(i) <> "" Then
                LL = Len(List(i))
                Mid$(Ret, j, LL) = List(i)
                j = j + LL
            End If
        Next
    Else
    'デリミタも置き換える
        j = 1
        If List(L) <> "" Then
            LL = Len(List(L))
            Mid$(Ret, j, LL) = List(L)
            j = j + LL
        End If
        
        For i = L + 1 To U
            Mid$(Ret, j, Ld) = Delimiter
            j = j + Ld
            
            If List(i) <> "" Then
                LL = Len(List(i))
                Mid$(Ret, j, LL) = List(i)
                j = j + LL
            End If
        Next
    End If
    
    Join97 = Ret
End Function
top

CSVファイルの並べ替え2 ― CSVファイルの並べ替え、簡易版(スピードよりも、CSV読み書きの分かり易さ重視)
 CSVの並べ替え CSVのSort CSV指定列で並べ替え ※並べ替えインデックスの取得用にMsCombSortI()を使用
Sub SortCSV()
    Dim myPath As String
    Dim N As Integer
    Dim D As String
    Const Cn As Integer = 4     '列数
    Const Kn As Integer = 2     'キー列番号
    Dim V() As Variant
    Dim i As Long, j As Long
    Dim Ky() As Variant
    Dim Ndx As Variant
    
    myPath = ThisWorkbook.Path & "\test.csv"
    N = FreeFile()
    Open myPath For Input As #N
    Do Until EOF(N)
        i = i + 1
        ReDim Preserve V(1 To Cn, 1 To i)
        ReDim Preserve Ky(1 To i)
        For j = 1 To Cn
            Input #N, V(j, i)
            If j = Kn Then
                Ky(i) = V(j, i)
            End If
        Next
    Loop
    Close #N
    
    Ndx = MsCombSortI(Ky)
    
    N = FreeFile()
    Open myPath For Output As #N
    For i = 1 To UBound(V, 2)
        Print #N, V(1, Ndx(i));
        For j = 2 To Cn
            Print #N, ","; V(j, Ndx(i));
        Next
        Print #N, ""
    Next
    Close #N
    
    MsgBox "完了!"
End Sub

Private Sub CreateTestDataFile()
    '範囲を指定した整数を羅列した、4列のテキストファイルを作る。
    Dim Fn As String
    Dim N As Long
    Dim i As Long
    Const L2 As Long = 1
    Const U2 As Long = 300
    Const L3 As Long = 1
    Const U3 As Long = 1000
    Const L4 As Long = 1
    Const U4 As Long = 700
    
    Fn = ThisWorkbook.Path & "\test.csv"
    N = FreeFile(0)
    
    Open Fn For Output As #N
    Randomize
    For i = 1 To 60000
        Print #N, i; ","; Int((U2 - L2 + 1) * Rnd() + L2) _
            ; ","; Int((U3 - L3 + 1) * Rnd() + L3) _
            ; ","; Int((U4 - L4 + 1) * Rnd() + L4)
    Next
    Close #N
End Sub
top

2行1レコードのデータをCSVに書き出す ― ワークシート上で2行で1レコードのデータをCSVファイルに書き出す例
 二行一レコード CSV出力
Sub CSV作成()
    '二行で一レコードのワークシート上のデータをCSVに書き出す
    Dim myPath As String
    Dim N As Integer
    Dim myRange As Range
    Dim myRow As Range
    Dim Flg As Boolean
    Dim i As Integer
    
    myPath = ActiveWorkbook.Path & "\Test.csv"
    N = FreeFile
    
    Set myRange = ActiveSheet.UsedRange
    
    Open myPath For Output As #N
    
    For Each myRow In myRange.Rows
        Flg = Not Flg
        
        If Flg Then
            Print #N, myRow.Cells(1).Value;
            For i = 2 To myRow.Cells.Count * 2
                Print #N, ","; myRow.Resize(2).Cells(i).Value;
            Next
            Print #N, ""
        End If
    Next
    Close #N
End Sub
top

別シートに分割 ― 同一項目毎に別シートにコピーする、Dictionaryを使った比較的スマートな方法
 別シート分割 同項目毎 分類 ※A列が同じ値のデータを別シートにコピーする、並べ替え不要
Sub 別シートに分割()
    '同項目毎に別シートに分割する
    Dim Dic As Object   'Dictionary
    Dim K As Variant
    Dim RR As Range
    Dim R As Range
    Dim T As Range  'タイトル
    
    Set T = Range("A1")
    Set RR = T.Offset(1)
    Set RR = Range(RR, RR.End(xlDown))
    
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1     'BinaryCompare=0, TextCompare=1
    
    For Each R In RR
        K = CStr(R.Value)
        If Dic.Exists(K) Then
            Set Dic(K) = Union(Dic(K), R)
        Else
            Set Dic(K) = Union(T, R)
        End If
    Next
    
    For Each K In Dic.Keys
        With Worksheets.Add
            .Name = K
            Set R = Dic(K)
            Set R = R.EntireRow
            Set R = Intersect(R, R.Worksheet.UsedRange)
            R.Copy .Range("A1")
        End With
    Next
    
    Set Dic = Nothing
End Sub
top

英語環境か日本語環境か ― 現在実行中の環境が英語環境か日本語環境かを返す関数
 実行環境 言語種別 言語環境
Function Language() As String
    Dim myStyle As Style
    Set myStyle = ThisWorkbook.Styles("Normal")
    
    Select Case myStyle.NameLocal
        Case "Normal"
            Language = "English"
        Case "標準"
            Language = "日本語"
        Case Else
            Language = "Other"
    End Select
    
    Set myStyle = Nothing
End Function
top

コマンドバートグルボタン ― コマンドバーボタンをトグルボタンとして使う例
 コマンドバーボタン トグルボタン ※適当な(ex. ニコちゃんマーク)ボタンを適当なツールバーに配置し、下記マクロを登録する
Sub コマンドバートグルボタン()
    Dim myButton As Office.CommandBarButton
    Set myButton = Application.CommandBars.ActionControl
    With myButton
        If .State = msoButtonUp Then
            'ボタンを押し込んだ時の処理
            ActiveSheet.DisplayAutomaticPageBreaks = True
            .State = msoButtonDown
        Else
            'ボタンを戻したときの処理
            ActiveSheet.DisplayAutomaticPageBreaks = False
            .State = msoButtonUp
        End If
    End With
    Set myButton = Nothing
End Sub
top

次回から表示しない ― アプリ起動時、「次回から表示しない」チェックボックスを表示する、テキストファイルをフラグに使用
 ※必要パーツ:UserForm1, chk次回から表示しない, cmdOK
===== ThisWorkbookモジュール =====
Option Explicit
Private flgText As String

Private Sub Workbook_Open()
    flgText = ThisWorkbook.Path & "\次回から表示しない.txt"
    If 表示しない Then Exit Sub
    
    UserForm1.Show
    If UserForm1.戻り値 = vbOK Then
        チェックON
    End If
    Unload UserForm1
End Sub

Private Function 表示しない() As Boolean
    If Dir(flgText) <> "" Then
        表示しない = True
    Else
        表示しない = False
    End If
End Function

Private Sub チェックON()
    Dim N As Integer
    N = FreeFile
    Open flgText For Output As #N
    Close #N
End Sub

===== UserForm1モジュール =====
Option Explicit
Public 戻り値 As Integer

Private Sub cmdOK_Click()
    If Me.chk次回から表示しない.Value = True Then
        戻り値 = vbOK
    Else
        戻り値 = vbCancel
    End If
    Me.Hide
End Sub

Private Sub UserForm_Initialize()
    戻り値 = vbCancel
    Me.chk次回から表示しない.Value = False
End Sub
top

選択範囲をテキスト出力 ― シートの選択範囲をタブ区切りテキストとして出力する
 シートの一部をテキスト出力 データオブジェクト
Sub WriteTxt()
    'シートの選択範囲をタブ区切りテキストとして出力する
    'Microsoft Forms x.x Object Libraryに参照設定要
    Dim Doj As DataObject
    Dim Txt As String
    Dim RR As Range
    Dim myPath As String
    Dim N As Integer
    
    Set RR = Selection
    RR.Copy
    Set Doj = New DataObject
    With Doj
        .GetFromClipboard
        Txt = .GetText
    End With
    Set Doj = Nothing
    Application.CutCopyMode = False
    
    myPath = ThisWorkbook.Path & "\test.txt"
    N = FreeFile()
    Open myPath For Output As #N
    Print #N, Txt;
    Close #N
End Sub
top

二段組 ― 縦長の表(複数列可)を半分で折り返して二段組にする、列幅もそろえ、周りを罫線で囲み、一行おきに色付けする
 表の折り返し 列幅コピー
Sub 二段組()
    Dim myRange As Range
    Dim R As Integer, C As Integer
    Dim myRow As Range
    Dim myColumn As Range
    
    Set myRange = Range("A1").CurrentRegion

    With myRange
        '項目数
        C = .Columns.Count
        '項目名のコピー
        .Rows(1).Copy .Cells(1, C + 1)
        '正味の行数の半分(元が奇数なら一行少なくコピペする)
        R = Int((.Rows.Count - 1) / 2)
        
        '下からR行分
        With .Rows(.Rows.Count).Offset(-R + 1).Resize(R)
            .Copy myRange.Cells(2, C + 1)
            .Clear
            '列幅のコピー
            For Each myColumn In .Columns
                With myColumn
                    .Offset(, C).ColumnWidth = .ColumnWidth
                End With
            Next
        End With
        
        '罫線で囲む
        '正味の行数の半分(元が奇数なら一行多い方)
        R = Application.WorksheetFunction _
            .RoundUp((.Rows.Count - 1) / 2, 0)
        '項目行とR行分を含む回りを罫線で囲む
        With .Rows(1).Resize(1 + R)
            .BorderAround LineStyle:=xlContinuous
            'コピペした隣も
            .Offset(, C).BorderAround LineStyle:=xlContinuous
        End With
    End With
    
    '一行おきに色付け
    R = 0
    For Each myRow In myRange.CurrentRegion.Rows
        R = Not R
        If R Then
            myRow.Interior.Color = vbYellow
        End If
    Next
End Sub
top

結合セル範囲毎の並べ替え ― A列に結合セル、B列に並べ替え対象データがあり、B列の値をA列の結合セル範囲毎に行う
 結合セル 並べ替え
Sub 結合セル範囲毎の並べ替え()
    Dim R As Range
    Dim C As Integer
    
    Set R = Range("B1")    '結合していない列を基準にして処理するのがみそ
    
    Do Until R.Offset(, -1).Value = ""
        C = R.Offset(, -1).MergeArea.Rows.Count
        R.Resize(C).Sort key1:=R, header:=xlNo
        Set R = R.Offset(C)
    Loop
End Sub
top

乱配列 ― 指定範囲の重複の無い乱配列を返す、添え字は1から ex. 指定範囲=5〜10 ==> {8,10,6,5,7,9}
 指定範囲の乱数 指定範囲の乱配列 ランダム
Sub test()
    Dim A As Variant
    Dim V As Variant
    
    A = 乱配列(5, 10)
    
    For Each V In A
        Debug.Print V;
    Next
    Debug.Print
    
End Sub

Function 乱配列(L As Integer, U As Integer) As Variant
    'LからUの範囲の重複の無い乱配列を返す。添え字は1から。
    Dim M As Integer
    Dim A As Variant
    Dim i As Integer
    Dim N As Integer
    Dim V As Integer
    
    M = U - L + 1
    ReDim A(1 To M)
    
    For i = 1 To M
        A(i) = i
    Next
    
    Randomize
    For i = M To 2 Step -1
        N = Int(Rnd() * i + 1)
        V = A(N)
        A(N) = A(i)
        A(i) = V
    Next
    
    For i = 1 To M
        A(i) = A(i) + L - 1
    Next
    
    乱配列 = A
End Function
top

乱順文字 ― 文字配列からランダムに重複無く1要素づつ取り出す ex. {"a","b","c","d","e","f"} ==> "cebfda"
 乱数 ランダムに並べ替え 重複無し
Sub 乱順文字()
    Dim A As Variant
    Dim L As Integer, U As Integer
    Dim N As Integer
    Dim i As Integer, j As Integer
    Dim S As String
    
    A = Array("A", "B", "C", "D", "E", "F")
    L = LBound(A)
    U = UBound(A)
    N = U
    
    Randomize
    For i = L To U - 1
        j = Int(Rnd() * (N - L + 1) + L)
        S = S & A(j)
        A(j) = A(N)
        N = N - 1
    Next
    S = S & A(L)
    
    Debug.Print S
End Sub
top

ランダムな文字列 ― 英字のランダムな文字列を返す関数
 ランダム文字列関数 テスト用データ作成 乱数で文字列作成
Sub SampleData()
    '3文字+数字2桁+15文字のランダムな文字列を作成する
    Dim A(1 To 10000, 1 To 1) As String
    Dim i As Long
    Dim S As String
    
    Randomize
    For i = 1 To 10000
        S = Format(Int(Rnd() * (99 - 1 + 1) + 1), "00")
        A(i, 1) = RndStr(3) & S & RndStr(15)
    Next
    Range("A1").Resize(UBound(A)).Value = A
End Sub

Private Function RndStr(N As Integer) As String
    'A-Z,a-zのランダムな文字列N個を返す
    Randomize
    Dim i As Integer
    Dim S As String
    Dim SS As String
    Dim A As Integer
    
    For i = 1 To N
        A = Int(Rnd() * 26)
        S = Chr$(Asc("A") + A)
        If Rnd() >= 0.5 Then
            S = LCase(S)
        End If
        SS = SS & S
    Next
    RndStr = SS
End Function
top

辞書例2 ― A列とB列を比較しB列のみの値をC列に抽出する簡易比較例(同一列内の同値は無視)
 列の比較 比較抽出 差分抽出 ※同一列内に同値がある場合は考慮していないので要注意
Sub 列比較抽出()
'A列とB列を比較しB列のみの値をC列に抽出する
    Dim Dic As Object
    Dim AA As Variant
    Dim BB As Variant
    Dim CC As Variant
    Dim rngDest As Range
    Dim V As Variant
    Dim i As Integer
    
    Set Dic = CreateObject("Scripting.Dictionary")
    
    With ActiveCell.Worksheet
        AA = .Range(.Range("A1"), .Range("A65536").End(xlUp)).Value
        BB = .Range(.Range("B1"), .Range("B65536").End(xlUp)).Value
        Set rngDest = .Range("C1")
    End With
    
    For Each V In AA
        Dic.Item(V) = Empty
    Next
    
    ReDim CC(1 To UBound(BB), 1 To 1)
    i = 0
    For Each V In BB
        If Not Dic.Exists(V) Then
            i = i + 1
            CC(i, 1) = V
        End If
    Next
    rngDest.Resize(i).Value = CC
    
    Set Dic = Nothing
    Set rngDest = Nothing
End Sub
top

辞書の例 ― Dictionaryオブジェクトの使用例、Sheet2の辞書範囲を使いSheet1に訳(Item)を表示する例
 スクリプティング ディクショナリの使用例 ※辞書はSheet2A列にkey、B列にitem、翻訳対象はSheet1A列
Sub 辞書例()
    Const KeyN As Integer = 1   'キー列
    Const ItemN As Integer = 2  'アイテム列
    
    Dim Dic As Object
    Dim rngDic As Range
    Dim myRange As Range
    Dim myCell As Range
    Dim myValues As Variant
    Dim myKey As Variant
    Dim i As Long
    
    Set rngDic = Worksheets("Sheet2").UsedRange
    Set myRange = Worksheets("Sheet1").Range("A1")
    Set myRange = Range(myRange, myRange.End(xlDown))
    
    Set Dic = CreateObject("Scripting.Dictionary")
    
    With rngDic
        For i = 1 To .Rows.Count
            Dic.Item(.Cells(i, KeyN).Value) _
                = .Cells(i, ItemN).Value
        Next
    End With
    
    ReDim myValues(1 To myRange.Rows.Count, 1 To 1)
    
    i = 0
    For Each myCell In myRange.Cells
        i = i + 1
        myKey = myCell.Value
        If Dic.Exists(myKey) Then
            myValues(i, 1) = Dic.Item(myKey)
        End If
    Next
    
    myRange.Offset(, 1).Value = myValues
End Sub
top

印刷が出来ない設定 ― ブックを印刷できないようにする
 印刷不可 印刷が出来ない 印刷キャンセル
対象のシート名が「Sheet1」だとして、 

1.ThisWorkbookモジュールに次のプログラムをコピペします。 
2.そして、非表示()をダイレクトに実行してシートを隠します。 
3.プロジェクトの保護をします。(もちろんパスワード付きで) 
4.ブックを保存します。 

これで、ブックを開く時にマクロを有効にしないとシートが表示されません。 
そして、マクロが有効になっていれば印刷はキャンセルされます。 
(ただし、PrintScreenでは出来てしまうなど、抜け道はありますが。^d^) 

Private Sub Workbook_BeforePrint(Cancel As Boolean) 
    Cancel = True 
End Sub 

Private Sub Workbook_Open() 
    With Worksheets("Sheet1") 
        .Visible = xlSheetVisible 
        .Select 
    End With 
    ThisWorkbook.Saved = True 
End Sub 

Private Sub 非表示() 
    Worksheets("Sheet1").Visible = xlSheetVeryHidden 
End Sub
top

アラビア数字から漢数字 ― アラビア数字を漢数字で表示するフォーマート文字列(123 ===> 百二十三、壱百弐拾参)
 算用数字から漢数字に変換 日付 変換 Format
[DBNum1]G/標準:123 ===> 百二十三

[DBNum2]G/標準:123 ===> 壱百弐拾参

[DBNum1]ggge"年"m"月"d"日":2005/7/9 ===> 平成十七年七月九日
top

複合キーによる検索 ― ワークシートを行単位で、スペース区切りのAND指定キーで検索
 ワークシートで複合キー検索 ワークシートでAND検索 シート検索
Option Explicit
Option Compare Text

Sub CallFind()
    Dim myRange As Range
    Dim Ans As Variant
    Static myKeys As String
    Dim rngFind As Range
    
    Set myRange = ActiveSheet.UsedRange
    Ans = Application.InputBox("検索キー入力", , myKeys, Type:=2)
    If Ans = False Then Exit Sub
    
    myKeys = Replace(CStr(Ans), " ", " ")

    Set rngFind = MsFind(myRange, myKeys, ActiveCell)
    If rngFind Is Nothing Then
        MsgBox "Not Found", vbExclamation
    Else
        rngFind.Select
    End If
    
End Sub

Private Function MsFind(Target As Range, Keys As String, Optional rngAfter As Range) As Range
    'Targetの行単位でKeysを検索し該当行への参照を返す。
    'Keysは、スペース区切りでアンド指定可
    Dim myRow As Range
    Dim myCell As Range
    Dim i As Integer
    Dim Flg As Boolean
    Dim myKeys As Variant
    Dim rngFind As Range
    Dim FirstAddress As String
    
    If Target Is Nothing Then Exit Function
    If Trim(Keys) = "" Then Exit Function
    
    If IsMissing(rngAfter) Then
        Set rngAfter = Target.Cells(Target.Cells.Count)
    End If
    If rngAfter Is Nothing Then
        Set rngAfter = Target.Cells(Target.Cells.Count)
    End If
    
    Set MsFind = Nothing
    
    myKeys = Split(Trim(Keys), " ")
    
    Set rngFind = Target.Find(what:=myKeys(LBound(myKeys)), after:=rngAfter, _
        LookIn:=xlValues, lookat:=xlPart, MatchCase:=False, MatchByte:=False)
    
    If rngFind Is Nothing Then Exit Function
    FirstAddress = rngFind.Address
    
    Do
        Set myRow = Intersect(rngFind.EntireRow, Target)
        For i = LBound(myKeys) To UBound(myKeys)
            Flg = False
            For Each myCell In myRow.Cells
                If myCell.Value Like "*" & myKeys(i) & "*" Then
                    Flg = True
                    Exit For
                End If
            Next
            If Flg = False Then
                Exit For
            End If
        Next
        
        If Flg = True Then
            Set MsFind = rngFind
            Exit Do
        End If
        
        Set rngFind = Target.FindNext(rngFind)
        
    Loop Until rngFind.Address = FirstAddress
    
End Function
top

ウィンドウを閉じるイベント ― [ウィンドウ]-[新しいウィンドウを開く]で開いたウィンドウを閉じた時のイベント
 ウィンドウクローズイベント 新しいウインドウ 2つめのウィンドウ
===== ThisWorkbookモジュール =====
Option Explicit

Private WithEvents myApp As Application
Private myCount As Integer
Private Flg As Boolean

Private Sub Workbook_Open()
    Set myApp = Application
    myCount = Application.Windows.Count
    Flg = False
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set myApp = Nothing
End Sub

Private Sub myApp_WindowActivate(ByVal Wb As Excel.Workbook, ByVal Wn As Excel.Window)
    If Flg Then
        If Application.Windows.Count < myCount Then
            MsgBox "ウインドウが閉じられました。"
        End If
    End If
    Flg = False
    myCount = Application.Windows.Count
End Sub

Private Sub myApp_WindowDeactivate(ByVal Wb As Excel.Workbook, ByVal Wn As Excel.Window)
    If InStr(Wn.Caption, ":") >= 1 Then
        Flg = True
    End If
End Sub
top

加算入力 ― セルに入力すると、その入力前に表示されていた値と入力値が加算して入力される、文字の場合は追加される
 表示値と加算 入力前の値と加算 加算入力 文字列の追加入力
===== シートモジュール =====
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim V As Variant
    With Target
        If .Count >= 2 Then Exit Sub
        V = .Value
        Application.EnableEvents = False
        Application.Undo
        If IsEmpty(V) Then    'Delキーを有効にするため
            .ClearContents
        Else
            If VarType(V) = vbString Or VarType(.Value) = vbString Then
                .Value = .Value & V
            Else
                .Value = .Value + V
            End If
        End If
        Application.EnableEvents = True
    End With
End Sub
top

一行おきの色付け ― オートフィルタをかけた後のデータに対して、一行おきに色付けをする
 一行おきに色付け オートフィルタ結果に縞模様 Hidden
Sub 一行おきの色付け()
    Dim myRange As Range
    Dim myRow As Range
    Dim Sw As Boolean
    
    Set myRange = ActiveSheet.AutoFilter.Range
    
    For Each myRow In myRange.Rows
        With myRow
            If Not .Hidden Then
                If Sw Then
                    .Interior.Color = vbYellow
                Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
                Sw = Not Sw
            End If
        End With
    Next
End Sub
top

UserCopy ― 通常のコピーペーストとは別に、独自にコピー元を保持しメニューからのペーストを実現する、ただしクリップボードの内容は破壊する
 独自のコピーペースト ユーザーコピー
Option Explicit

Private rngSource As Range

Public Sub AddMenu()
    Dim myMenuCopy As CommandBarButton
    Dim myMenuPast As CommandBarButton
    
    With Application.CommandBars("Cell")
        Set myMenuPast = .Controls.Add(before:=1, temporary:=True)
        Set myMenuCopy = .Controls.Add(before:=1, temporary:=True)
        .Controls(3).BeginGroup = True
    End With
    
    With myMenuCopy
        .Caption = "UserCopy"
        .OnAction = "UserCopy"
    End With
    With myMenuPast
        .Caption = "UserPast"
        .OnAction = "UserPast"
    End With
    
End Sub

Public Sub DelMenu()
    On Error Resume Next
    With Application.CommandBars("Cell")
        .Controls("UserCopy").Delete
        .Controls("UserPast").Delete
    End With
    On Error GoTo 0
    If Not rngSource Is Nothing Then
        rngSource.Interior.ColorIndex = xlNone
    End If
End Sub

Private Sub UserCopy()
    If Not rngSource Is Nothing Then
        rngSource.Interior.ColorIndex = xlNone
    End If
    Set rngSource = Selection
    'コピー元がユーザーに分かるように色を塗っておく
    rngSource.Interior.Color = vbCyan
End Sub

Private Sub UserPast()
    If rngSource Is Nothing Then Exit Sub
    rngSource.Copy
    Selection.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End Sub
top

ToolButton ― 「フォーム」ツールバー、「コントロールツールボックス」ツールバーの表示非表示を切り替えるボタンをメニューバーに追加
 フォームツールバー コントロールツールボックスツールバー ツールバー表示切替 ※このマクロブックのプロジェクト名を「ToolButton」とすること
===== ThisWorkbook =====
Option Explicit

Private Const ToolName1 As String = "フォームBox"
Private Const ToolName2 As String = "ツールBox"

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    DelButton
End Sub

Private Sub Workbook_Open()
    AddButton
End Sub

Private Sub AddButton()
    Dim myButton As CommandBarButton
    
    With Application.CommandBars("Worksheet Menu Bar")
        Set myButton = .Controls.Add _
            (Type:=msoControlButton, temporary:=True)
        With myButton
            .Style = msoButtonCaption
            .Caption = ToolName1
            .OnAction = "ToolButton.ThisWorkbook.FormBox"
        End With
    
        Set myButton = .Controls.Add _
            (Type:=msoControlButton, temporary:=True)
        With myButton
            .Style = msoButtonCaption
            .Caption = ToolName2
            .OnAction = "ToolButton.ThisWorkbook.ToolBox"
        End With
    End With
End Sub

Private Sub DelButton()
    On Error Resume Next
    With Application.CommandBars("Worksheet Menu Bar")
        .Controls(ToolName1).Delete
        .Controls(ToolName2).Delete
    End With
    On Error GoTo 0
End Sub

Private Sub FormBox()
    With Application.CommandBars("Forms")
        .Visible = Not .Visible
    End With
End Sub

Private Sub ToolBox()
    With Application.CommandBars("Control Toolbox")
        .Visible = Not .Visible
    End With
End Sub
top

CSVをまとめる4 ― 複数のCSVファイルを文字列書式で各々シートとしてブックにまとめる
 フォルダ内CSV結合 CSVファイル読み込み CSVを別シートとして読み込み ※別途フォルダ選択関数要
Sub ReadCsv()
    Dim Fld As String
    Dim Fn As String
    Dim N As Integer
    Dim Book As Workbook
    Dim Sht As Worksheet
    Dim VV As Variant   '一ファイルすべてのデータ
    Dim V As Variant    '一行分のデータ
    Dim i As Long
    Dim CC As Integer   '列数
    
    Fld = フォルダ選択()
    If Fld = "" Then Exit Sub
    
    Fn = Dir(Fld & "\*.csv")
    If Fn = "" Then Exit Sub
    
    Set Book = Workbooks.Add
    
    Do Until Fn = ""
        With Book
            Set Sht = .Worksheets.Add(after:=.Sheets(.Sheets.Count))
        End With
        
        N = FreeFile
        Open Fld & "\" & Fn For Input As #N
        VV = InputB(LOF(N), N)
        VV = StrConv(VV, vbUnicode)
        VV = Split(VV, vbCrLf)
        Close #N
        
        V = Split(VV(0), ",")
        CC = UBound(V) + 1
        Sht.Range("A:A").Resize(, CC).NumberFormat = "@"
        
        For i = 0 To UBound(VV)
            V = Split(VV(i), ",")
            Sht.Cells(i + 1, 1).Resize(, CC).Value = V
        Next
        Sht.Name = Left$(Fn, Len(Fn) - 4)
        
        Fn = Dir()
    Loop
    
    Application.DisplayAlerts = False
    For i = 1 To Application.SheetsInNewWorkbook
        Book.Sheets(1).Delete
    Next
    Application.DisplayAlerts = True
    
    MsgBox "完了!"
End Sub
top

CSVをまとめる3 ― 複数のテキストファイルをひとつにまとめる、FSOで読み書きする例(各先頭行にはファイル名挿入)
 複数のCSVファイル結合 複数テキストファイルの結合
Sub ChainCsv()
    Dim Fls As Variant
    Dim F As Variant
    Dim Fso As Object   'FileSystemObject
    Dim Ts As Object    'TextStream
    Dim V As String
    Dim VV As String
    Dim OutPath As Variant
    
    Fls = Application.GetOpenFilename("CVSファイル(*.csv),*.csv,全てのファイル(*.*),*.*", _
        Title:="まとめるファイルを選択してください。", MultiSelect:=True)
    If TypeName(Fls) = "Boolean" Then Exit Sub
    
    OutPath = ThisWorkbook.Path & "\Out.Txt"
    OutPath = Application.GetSaveAsFilename(OutPath, _
        Title:="書き出し先ファイル名を入力してください。")
    If VarType(OutPath) = vbBoolean Then Exit Sub
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    
    VV = ""
    For Each F In Fls
        Set Ts = Fso.OpenTextFile(F, 1)  'ForReading
        With Ts
            V = .ReadAll
            
            '最後が改行でない時は強制挿入
            If VV <> "" And Right$(VV, 2) <> vbCrLf Then
                VV = VV & vbCrLf
            End If
            
            VV = VV & Dir(F) & vbCrLf & V
            .Close
        End With
    Next
    
    Set Ts = Fso.OpenTextFile(OutPath, 2, True)  'ForWriting
    With Ts
        .Write VV
        .Close
    End With
    
    Set Ts = Nothing
    Set Fso = Nothing
End Sub
top

行列に並べ替え ― DB形式のデータの2列をXとYとして行列形式に並べ替える
 DB形式を行列形式に並べ替え 縦横並べ替え ※Join, Csort, Split 関数を使用
点数 名前 番号
90  田中 2
80  田中 3
85  田中 1
95  山田 1
   小林 1
70  佐藤 1  
70  佐藤 2  
85  鈴木 1  
80  吉田 2  
90  吉田 3  
70  吉田 4  
85  吉田 3  
 ↓
    1  2  3  4
吉田     85
     80 90 70
佐藤 70 70
山田 95
小林
田中 85 90 80
鈴木 85

Sub 行列に並べ替え()
    Dim RR As Range
    Dim V0 As Variant
    Dim V1 As Variant
    Dim dicX As Object
    Dim dicY As Object
    Dim XX As String, YY As String
    Dim Rmax As Long, Cmax As Long
    Dim R As Long, C As Long
    Dim rngDest As Range
    Const jX As Integer = 3 'X列
    Const jY As Integer = 2 'Y列
    Const jZ As Integer = 1 'データ列
    Dim i As Long, j As Long
    
    'Dictionaryで行列各々の、値対番号を管理する
    Set dicX = CreateObject("Scripting.Dictionary")
    Set dicY = CreateObject("Scripting.Dictionary")
    
    '元データ
    Set RR = Range("A1").CurrentRegion
    Set RR = RR.Offset(1).Resize(RR.Rows.Count - 1, 3)
    V0 = RR.Value
    
    '並べ替えた値の入れ物(行列共、最大値が既知ならその値にした方が良い)
    ReDim V1(0 To UBound(V0), 0 To 255)
    
    For i = 1 To UBound(V0)
        '行の値
        YY = V0(i, jY)
        If Not dicY.Exists(YY) Then
        '新規なら行カウントアップ
            Rmax = Rmax + 1
            dicY.Item(YY) = Rmax
            R = Rmax
            '行タイトル
            V1(R, 0) = YY
        Else
        '既出なら
            R = dicY.Item(YY)
        End If
        
        '列の値
        XX = V0(i, jX)
        If Not dicX.Exists(XX) Then
        '新規なら列カウントアップ
            Cmax = Cmax + 1
            dicX.Item(XX) = Cmax
            C = Cmax
            '列タイトル
            V1(0, C) = XX
        Else
        '既出なら
            C = dicX.Item(XX)
        End If
        
        '値を設定する
        If V1(R, C) = "" Then
            V1(R, C) = V0(i, jZ)
        Else
            V1(R, C) = V1(R, C) & vbLf & V0(i, jZ)
        End If
    Next
    
    '1箇所に2つ以上データがある場合は並べ替える(ただし文字としての並べ替え)
    For i = 1 To Rmax
        For j = 1 To Cmax
            If InStr(V1(i, j), vbLf) >= 1 Then
                V1(i, j) = join(Csort(Split(CStr(V1(i, j)), vbLf)), vbLf)
            End If
        Next
    Next

    Application.ScreenUpdating = False

    '新規シートを追加して書き込み、並べ替え
    Set rngDest = Worksheets.Add.Range("A1")
    With rngDest.Resize(Rmax + 1, Cmax + 1)
        .Value = V1
        '行方向の並べ替え
        With .Offset(1).Resize(.Rows.Count - 1)
            .Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        End With
        '列方向の並べ替え(なぜかHeader:=xlYesが効かない為このような書き方にした、行方向はこれに合わせた)
        With .Offset(, 1).Resize(, .Columns.Count - 1)
            .Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
        End With
    End With

    Application.ScreenUpdating = True
    
    Set RR = Nothing
    Set rngDest = Nothing
    Set dicX = Nothing
    Set dicY = Nothing
End Sub
top

ファイル数カウント2 ― 指定フォルダ中の指定パターンにマッチしたファイル数を返す関数、FSO版
 ファイル数 パターン FileSystemObject
Sub test()
    MsgBox FilesCount(ThisWorkbook.Path, "*.xls")
End Sub

Function FilesCount(Fp As String, Ptn As String) As Long
    Dim Fso As Object
    Dim Fl As Object
    Dim F As Object
    Dim C As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Fl = Fso.GetFolder(Fp)
    For Each F In Fl.Files
        If LCase(F.Name) Like LCase(Ptn) Then
            C = C + 1
        End If
    Next
    FilesCount = C
    Set F = Nothing
    Set Fl = Nothing
    Set Fso = Nothing
End Function
top

ファイル数カウント ― フォルダ中の特定の拡張子のファイル数をカウントする、Dir関数版
 ファイル数 カウント 拡張子
Sub test()
    MsgBox FilesCount(ThisWorkbook.Path, "xls")
End Sub

Function FilesCount(Path As String, Ext As String) As Long
    Dim C As Long
    Dim Dummy As String
    Dummy = Dir(Path & "\*." & Ext)
    Do Until Dummy = ""
        C = C + 1
        Dummy = Dir()
    Loop
    FilesCount = C
End Function
top

2バイト文字を2桁、1バイト文字を1桁として扱う文字列関数(LenB, LeftB, RightB, MidB関数を普通の感覚で使えるようにした代用関数)
 2バイト文字と1バイト文字を区別して扱う文字列関数
Sub test()
    Const S As String = "あいabc123う"
    Debug.Print LenByte(S)          '12
    Debug.Print LeftByte(S, 5)      'あいa
    Debug.Print RightByte(S, 3)     '3う
    Debug.Print MidByte(S, 3, 3)    'いa
End Sub

Public Function LenByte(S As String) As Integer
    LenByte = LenB(StrConv(S, vbFromUnicode))
End Function

Public Function LeftByte(ByVal S As String, L As Integer) As String
    S = StrConv(S, vbFromUnicode)
    S = LeftB$(S, L)
    LeftByte = StrConv(S, vbUnicode)
End Function

Public Function RightByte(ByVal S As String, L As Integer) As String
    S = StrConv(S, vbFromUnicode)
    S = RightB$(S, L)
    RightByte = StrConv(S, vbUnicode)
End Function

Public Function MidByte(ByVal S As String, P As Integer, Optional L) As String
    S = StrConv(S, vbFromUnicode)
    If IsMissing(L) Then
        S = MidB$(S, P)
    Else
        S = MidB$(S, P, L)
    End If
    MidByte = StrConv(S, vbUnicode)
End Function
top

固定長ファイル読み込み ― 固定長のテキストファイルを全角文字を二桁、半角文字を一桁として読み込む
 固定長テキストファイル 全角を二桁 全角半角を区別
固定長テキストファイル
ID   名称      色      大きさ     重さ
0001   みかん     オレンジ   8cm      100g
0002   りんご     赤      12cm      200g
0003   メロン     黄緑     23cm      800g

Sub 固定長読み込み()
    Dim myStru As Variant
    Dim myPos() As Integer
    Dim myPath As String
    Dim N As Integer
    Dim rngDest As Range
    Dim i As Integer
    Dim D As String
    
    '各項目の桁数
    myStru = Array(8, 12, 12, 12, 4)
    
    '各項目の左端ポジション
    ReDim myPos(0 To UBound(myStru))
    myPos(0) = 1
    For i = 0 To UBound(myStru) - 1
        myPos(i + 1) = myPos(i) + myStru(i)
    Next
    
    '読み込みファイル
    myPath = ThisWorkbook.Path & "\test.txt"
    N = FreeFile
    
    '書き出し先
    Set rngDest = Range("A1")
    '書式を文字に変える
    rngDest.Resize(, UBound(myPos) + 1).EntireColumn.NumberFormat = "@"
    
    '読み込む
    Open myPath For Input As #N
    Do Until EOF(N)
        '一行丸ごと読み込み
        Line Input #N, D
        '各項目の値に切り分けながら、書き込む
        For i = 0 To UBound(myStru)
            rngDest.Offset(, i).Value = MidByte(D, myPos(i), myStru(i))
        Next
        '書き込み先を下に移動
        Set rngDest = rngDest.Offset(1)
    Loop
    
    Close #N
End Sub

Private Function MidByte(ByVal S As String, ByVal P As Integer, ByVal L As Integer) As String
    '2バイト文字を2バイト、1バイト文字を1バイトとして扱うMidB関数
    S = StrConv(S, vbFromUnicode)
    S = MidB$(S, P, L)
    MidByte = StrConv(S, vbUnicode)
End Function
top

タブ区切りテキストの読み込み3 ― セル内改行可(vbCrLfでもOK)の例、ただしMsToolsC要参照設定、比較的遅いが行数制限は無し
 タブ区切りテキストファイル セル内改行 ダブルクォーテーションカット ※MsToolsCへの参照設定要
Sub ReadTxt2()
    Dim myPath As String
    Dim N As Integer
    Dim A0 As Variant
    Dim A1 As Variant
    Dim rngDest As Range
    Dim D As String
    Dim i As Long
    
    myPath = ThisWorkbook.Path & "\test.txt"
  
    Application.ScreenUpdating = False
  
    N = FreeFile
    Open myPath For Input As #N
    D = InputB(LOF(N), N)
    D = StrConv(D, vbUnicode)
    Close #N
    
    '行に分解
    A0 = MsToolsC.MsSplit(D, vbCrLf)
    '読み込み先
    Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
    
    For i = 1 To UBound(A0)
        A1 = MsToolsC.MsSplit(CStr(A0(i)), vbTab)
        
        rngDest.Resize(, UBound(A1)).Value = A1
        Set rngDest = rngDest.Offset(1)
    Next
    
    rngDest.Worksheet.UsedRange.Replace Chr$(34), ""
    
    Application.ScreenUpdating = True
End Sub
top

最小二乗法 ― ワークシート関数LinEstで近似式の係数を得る
 二次方程式 二次関数 曲線式 回帰計算
y	x
8	-3
4.5	-2
1	-1
0.5	0
1.5	1
5.5	2
9.5	3

計算結果(y = 0.9286x^2 + 0.25x + 0.6429)
0.928571429, 0.25, 0.642857143

Sub 最小二乗法()
    Dim rngY As Range
    Dim rngX As Range
    Dim SourceY As Variant
    Dim SourceX As Variant
    Dim i As Integer
    Dim L As Integer
    Dim U As Integer
    Dim Ans As Variant
    
    '元データ
    With Range("A1").CurrentRegion
        Set rngY = 項目カット(.Columns("A"))
        Set rngX = 項目カット(.Columns("B"))
        SourceY = rngY.Value
        SourceX = rngX.Resize(,2).Value
    End With
    
    'X2乗を付加
    L = LBound(SourceX): U = UBound(SourceX)
    For i = L To U
        SourceX(i, 2) = SourceX(i, 1) ^ 2
    Next
    
    '計算
    Ans = Application.WorksheetFunction.LinEst(SourceY, SourceX)
    
    '計算結果表示
    rngX.Cells(rngX.Cells.Count + 2).Resize(, UBound(Ans)).Value = Ans
End Sub

Private Function 項目カット(R As Range) As Range
    Set 項目カット = Intersect(R, R.Offset(1))
End Function
top

シートをひとまとめ ― すべてのワークシートの内容を新規シートにひとまとめにする
 シートデータの統合 シートデータ結合 シートデータをまとめる ※各シートにはタイトル行がありタイトルは一回のみコピー
Sub シートを一まとめ()
    Dim myBook As Workbook
    Dim rngDest As Range
    Dim Sht As Worksheet
    Dim myRange As Range
    Dim C As Integer
    
    '元データブック(まとめ先が別ブックでも対応するため)
    Set myBook = ActiveWorkbook
    'まとめ先
    Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
    
    For Each Sht In myBook.Worksheets
        'そのシートが書き込み先のシートならパス(同一ブック時の対応)
        If Sht Is rngDest.Worksheet Then
        Else
            'コピー範囲
            Set myRange = Sht.UsedRange
            '二つめ以降なら項目名を除く
            C = C + 1
            If C >= 2 Then
                Set myRange = Intersect(myRange, myRange.Offset(1))
            End If
            'コピー&ペースト
            myRange.Copy rngDest
            '書き込み先を下に移動
            Set rngDest = rngDest.Offset(myRange.Rows.Count)
        End If
    Next
End Sub
top

シンクロ並べ替え2 ― 列データをシンクロする、Dictionaryを使用しない版
 列どうしをシンクロ 並列並べ替え ※両列共に昇順に並べ替え済であること
 1  2   1 
 2  3   2  2
 4  4      3
 5  6 ⇒ 4  4
 7  7   5 
 8  9      6
 9 11   7  7
10 12   8 
        9  9
       10 
          11
          12

Sub シンクロ()
    Dim rngA As Range, rngB As Range
    Dim AA As Variant, BB As Variant
    Dim cA As Long, cB As Long, C As Long
    Dim cAmax As Long, cBmax As Long
    Dim Dest As Variant
    Dim A As Variant, B As Variant
    
    Set rngA = Range("A1", Range("A65536").End(xlUp))
    Set rngB = Range("B1", Range("B65536").End(xlUp))
    
    AA = rngA.Value: BB = rngB.Value
    cAmax = UBound(AA): cBmax = UBound(BB)
    
    ReDim Dest(1 To cAmax + cBmax, 1 To 2)
    
    cA = 1: cB = 1: C = 1
    Do Until cA > cAmax Or cB > cBmax
        A = AA(cA, 1): B = BB(cB, 1)
        If A = B Then
            Dest(C, 1) = A
            cA = cA + 1
            Dest(C, 2) = B
            cB = cB + 1
        ElseIf A < B Then
            Dest(C, 1) = A
            cA = cA + 1
        Else
            Dest(C, 2) = B
            cB = cB + 1
        End If
        C = C + 1
    Loop
    
    Do Until cA > cAmax
        A = AA(cA, 1)
        Dest(C, 1) = A
        cA = cA + 1
        C = C + 1
    Loop
    
    Do Until cB > cBmax
        B = BB(cB, 1)
        Dest(C, 2) = B
        cB = cB + 1
        C = C + 1
    Loop
    
    '新規シートを追加して書き込み
    Worksheets.Add.Range("A1").Resize(C, 2).Value = Dest
    
    Set rngA = Nothing
    Set rngB = Nothing
End Sub
top

文字を一文字づつに分解して各セルに配置 ― 右詰めで「,」は除いて配置する(通貨形式の「,」付きの値を、1セル1桁に分解する)
 文字列分解 1文字づつセルに配置 ※例:「12,345」 → 「」「」「」「」「」「1」「2」「3」「4」「5」
Sub Bunkai()
    Dim myCell As Range
    Dim rngDest As Range
    Dim S As String
    Dim i As Integer
    
    '元値の位置
    Set myCell = Range("A1")
    '書込み先の最右端
    Set rngDest = Range("K2")
    
    '「,」を取り除く
    S = Replace(myCell.Text, ",", "")
    '書込み先の最初の位置
    Set rngDest = rngDest.Offset(, -Len(S) + 1)
    
    '一文字づつ分解して書き込む
    For i = 1 To Len(S)
        rngDest.Offset(, i - 1).Value = Mid$(S, i, 1)
    Next
End Sub
top

選択物からグラフを選別 ― 選択されているもの(Selection)の中からグラフのみを選別し処理する
 グラフのみ選別 グラフのみ選択処理
Sub GetChart()
    Dim myChart As Chart
    Dim myShape As Shape
    
    Select Case TypeName(Selection)
        Case "ChartObject", "DrawingObjects"
            For Each myShape In Selection.ShapeRange
                With myShape
                    If .Type = msoChart Then
                        Set myChart = ActiveSheet _
                            .ChartObjects(.Name).Chart
                        Debug.Print myChart.Name
                        ModifySeries myChart
                    End If
                End With
            Next
        Case "Range"
            'nop
        Case Else
            On Error Resume Next
            Set myChart = ActiveChart
            On Error GoTo 0
            If Not myChart Is Nothing Then
                Debug.Print myChart.Name
                ModifySeries myChart
            End If
    End Select
End Sub

Sub ModifySeries(Target As Chart)
    Dim mySeries As Series
    With Target
        Set mySeries = .SeriesCollection(1)
        With mySeries
            .Border.ColorIndex = 3
        End With
    End With
End Sub
top

田の字メニューもどき ― 罫線ツールボタンのような、前回実行したボタン内容が保持されるメニューのもどき版
 罫線ツール メニュー保持 階層メニュー
===== ThisWorkbook =====
Option Explicit

Public ButtonCaption As String
Private Const PopupCaption As String = "▼"

Private Sub AddMenu()
    Dim myButton As CommandBarButton
    Dim myPopup As CommandBarPopup
    Dim myCommandBar As CommandBar
    Dim Ctrl As CommandBarButton
    
    ButtonCaption = "AAA_1"
    
    'ボタン部分の追加
    Set myButton = Application.CommandBars("Worksheet Menu Bar") _
        .Controls.Add(Type:=msoControlButton, temporary:=True)
    With myButton
        .Caption = ButtonCaption
        .OnAction = ButtonCaption
        .Style = msoButtonCaption
    End With
    
    'ポップアップ部分の追加
    Set myPopup = Application.CommandBars("Worksheet Menu Bar") _
        .Controls.Add(Type:=msoControlPopup, temporary:=True)
    myPopup.Caption = PopupCaption
    Set myCommandBar = myPopup.CommandBar
    
    'ポップアップのサブメニューの追加
    With myCommandBar
        Set myPopup = .Controls.Add(Type:=msoControlPopup, temporary:=True)
        myPopup.Caption = "AAA"
            Set Ctrl = myPopup.CommandBar.Controls.Add _
                (Type:=msoControlButton, temporary:=True)
            With Ctrl
                .Caption = "AAA_1"
                .OnAction = "AAA_1"
            End With
            
            Set Ctrl = myPopup.CommandBar.Controls.Add _
                (Type:=msoControlButton, temporary:=True)
            With Ctrl
                .Caption = "AAA_2"
                .OnAction = "AAA_2"
            End With
            
        Set myPopup = .Controls.Add(Type:=msoControlPopup, temporary:=True)
        myPopup.Caption = "BBB"
            Set Ctrl = myPopup.CommandBar.Controls.Add _
                (Type:=msoControlButton, temporary:=True)
            With Ctrl
                .Caption = "BBB_1"
                .OnAction = "BBB_1"
            End With
            
            Set Ctrl = myPopup.CommandBar.Controls.Add _
                (Type:=msoControlButton, temporary:=True)
            With Ctrl
                .Caption = "BBB_2"
                .OnAction = "BBB_2"
            End With
    End With
    
    Set Ctrl = Nothing
    Set myCommandBar = Nothing
    Set myPopup = Nothing
    Set myButton = Nothing
    
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    With Application.CommandBars("Worksheet Menu Bar")
        .Controls(ButtonCaption).Delete
        .Controls(PopupCaption).Delete
    End With
    On Error GoTo 0
End Sub

Private Sub Workbook_Open()
    AddMenu
End Sub

===== 標準モジュール =====
Sub AAA_1()
    MsgBox "AAA_1"
    ChangeButton "AAA_1", "AAA_1"
End Sub

Sub AAA_2()
    MsgBox "AAA_2"
    ChangeButton "AAA_2", "AAA_2"
End Sub

Sub BBB_1()
    MsgBox "BBB_1"
    ChangeButton "BBB_1", "BBB_1"
End Sub

Sub BBB_2()
    MsgBox "BBB_2"
    ChangeButton "BBB_2", "BBB_2"
End Sub

Sub ChangeButton(Cap As String, Act As String)
    With Application.CommandBars("Worksheet Menu Bar") _
            .Controls(ThisWorkbook.ButtonCaption)
        .Caption = Cap
        .OnAction = Act
    End With
    ThisWorkbook.ButtonCaption = Cap
End Sub
top

ボールが弾む ― ボールがポンポンと弾むシミュレーション
 バウンド 跳ね返りシミュレーション 自然落下 ※必要パーツ:UserForm1, lblボール(Capton="●"), cmd実行, cmdReset
===== UserForm1 =====
Option Explicit

Private Const 落下加速度 As Double = 1000   'Point/sec^2
Private Const 減衰率 As Double = 0.8
Private Const 水平減衰率 As Double = 0.99
Private 初期高さ As Double
Private 初期Left As Double
Private flgReset As Boolean

Private Sub cmd実行_Click()
    Dim 水平速度 As Double  'Point/sec
    Dim 垂直初速 As Double  'Point/sec
    Dim T As Double         '時間
    Dim Tstep As Double     '計算時間間隔
    Dim H0 As Double        '高さ初期値
    Dim H As Double         '高さ
    Dim L As Double         'Left位置
    Dim 進行方向 As Integer '1.右向き  -1.左向き
    Dim T0 As Double        '前回落下時間
    Dim C As Integer        '落下時間が同じであった回数
    Dim 有効幅 As Double    'フォームの有効幅
    Dim 有効高さ As Double  'フォームの有効高さ
    
    水平速度 = 100
    Tstep = 0.01
    進行方向 = 1
    flgReset = False
    
    With Me.lblボール
        '-3は右端の影の部分
        有効幅 = Me.Width - .Width - 3
        '-18はトップのタイトルの高さ
        有効高さ = Me.Height - .Height - 18
        'デザイン時の位置取得
        .Top = 初期高さ
        .Left = 初期Left
        'H0:落下高さ計算時の初期高さ
        H0 = .Top
        '値の保持と計算はフォームの一番下を原点0として行う
        H0 = 有効高さ - H0
        'Leftは、左右の等速運動(減衰は入れるが)で前の値に _
        加算してゆく形としたのでL0は無し、上下は上頂点と下の _
        跳ね返り時に各々時間をリセットし初期高さからの位置を _
        計算しているのでH0を設定している
        L = .Left
    Do
        '落下
        T = 0
        H = H0
        Do
            '時間待ち
            Waitt Tstep
            T = T + Tstep
            
            '落下高さ、跳ね返り点を越えたら0とする
            H = 高さ(H0, 0, T)
            If H < 0 Then
                H = 0
            End If
            
            '水平位置、左右を越えたら超えた分逆の跳ね返った位置にする
            L = L + 水平速度 * Tstep * 進行方向
            If L > 有効幅 Then
                進行方向 = -1
                L = 有効幅 - (L - 有効幅)
            ElseIf L < 0 Then
                進行方向 = 1
                L = -L
            End If
            
            'ボールの移動、Topはコントロールの座標に変換して設定
            .Top = 有効高さ - H
            .Left = L
        Loop While H > 0
        
        水平速度 = 水平速度 * 水平減衰率
        
        '落下時間が収束してしまったらその回数をカウントする
        If T0 = T Then
            C = C + 1
        Else
            T0 = T
        End If
        
        '落下時間が収束し規定回数を超えたら
        If C > 5 Then
            'ボールは下に固定し
            .Top = 有効高さ
            Do
                '水平方向の動きだけにする
                L = L + 水平速度 * Tstep * 進行方向
                If L > 有効幅 Then
                    進行方向 = -1
                    L = 有効幅 - (L - 有効幅)
                ElseIf L < 0 Then
                    進行方向 = 1
                    L = -L
                End If
                .Left = L
                
                Waitt Tstep
                水平速度 = 水平速度 * 水平減衰率
                
                '水平速度が規定値未満になったら終わる
                If Abs(水平速度) < 1 Then
                    Exit Do
                End If
            Loop
            Exit Do
        End If
        
        If flgReset Then Exit Do
        
        '跳ね返り位置での本当の経過時間の平均
        T = T - Tstep / 2
        
        '上昇
        垂直初速 = -落下加速度 * T * 減衰率
        T = 0
        H = 0
        '垂直方向のスピードが0以下つまり上向きの間
        Do While 垂直初速 + 落下加速度 * T <= 0
            .Top = 有効高さ - H
            .Left = L
            
            Waitt Tstep
            T = T + Tstep
            
            'ここでの引数「初期高さ」は0
            H = 高さ(0, 垂直初速, T)
            
            L = L + 水平速度 * Tstep * 進行方向
            If L > 有効幅 Then
                進行方向 = -1
                L = 有効幅 - (L - 有効幅)
            ElseIf L < 0 Then
                進行方向 = 1
                L = -L
            End If
        Loop
        
        '頂点の折り返し位置での本当の経過時間の平均
        T = T - Tstep / 2
        H0 = 高さ(0, 垂直初速, T)
        
        If flgReset Then Exit Do
    Loop
    
    End With
    
End Sub

Private Function 高さ(初期高さ As Double, _
                    垂直初速 As Double, _
                    T As Double) As Double
    't秒経過時の高さを返す(垂直初速:下向きを+とする)
    Dim H As Double
    H = 落下加速度 * T * T / 2
    H = H + 垂直初速 * T
    高さ = 初期高さ - H
End Function

Private Sub Waitt(T As Double)
    Dim T1 As Double
    T1 = Timer + T
    Do While Timer < T1
        DoEvents
    Loop
End Sub

Private Sub cmdReset_Click()
    flgReset = True
    With Me.lblボール
        .Top = 初期高さ
        .Left = 初期Left
    End With
End Sub

Private Sub UserForm_Initialize()
    With Me.lblボール
        初期高さ = .Top
        初期Left = .Left
    End With
End Sub
top

発注番号自動設定 ― 発注書.xlt(テンプレートファイル)から新規作成したファイルを保存する際に自動的に連番を付加する
 テンプレート使用時に連番自動付加 自動で連番 ※マクロはテンプレートファイルとは別のファイルに保存する、アドインにして登録しておくと便利かも
===== ThisWorkbook =====
Option Explicit

Private WithEvents myApp As Application

Private Sub myApp_WorkbookBeforeSave(ByVal Wb As Excel.Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
    番号取得と設定 Wb
End Sub

Private Sub Workbook_Open()
    Set myApp = Application
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set myApp = Nothing
End Sub

Private Sub 番号取得と設定(Wb As Workbook)
    Dim Target As Range
    Dim myPath As String
    Dim N As Integer
    Dim Number As Long

    If Wb.Name = ThisWorkbook.Name Then Exit Sub
    If LCase(Wb.Name) Like "*.xlt" Then Exit Sub
    If Not Wb.Name Like "発注書*" Then Exit Sub
    '連番記入場所
    Set Target = Wb.Worksheets("Sheet1").Range("A1")

    If Target.Value <> "" Then Exit Sub

    myPath = ThisWorkbook.Path & "\最終発注番号.txt"

    N = FreeFile
    Open myPath For Input As #N
    Input #N, Number
    Close #N
    Number = Number + 1

    N = FreeFile
    Open myPath For Output As #N
    Print #N, Number
    Close #N

    Target.Value = Number
End Sub
top

ReadCsv3 ― CSVファイルの読み込み、シンプルコード版、ファイルの読み込みを任意のセル位置から行なう
 任意の改行コード対応 任意の区切り文字対応 CSVファイルの一括読み込みとSplitによる行列分割
Sub ReadCsv3()
    'CSVファイルを任意のセル位置へ読み込む
    Const myPath As String = "test.csv"
    Dim N As Integer
    Dim D As String
    Dim VV As Variant
    Dim V As Variant
    Dim A As Variant
    Dim R As Range
    
    '読み込み先
    Set R = Range("A1")
    
    N = FreeFile
    Open myPath For Input As #N
    D = InputB(LOF(N), N)
    D = StrConv(D, vbUnicode)
    Close #N
    
    VV = Split(D, vbCrLf)
    For Each V In VV
        A = Split(CStr(V), ",")
        R.Resize(, UBound(A) + 1).Value = A
        Set R = R.Offset(1)
    Next
End Sub
top

グループに罫線 ― 同じ値の続く範囲を罫線で囲む
 同一値範囲を罫線で囲む グループ処理
Sub グループ罫線()
    'A列の同一値基準で、A列からD列のセル範囲を罫線で囲む
    Dim S As Range
    Dim E As Range
    Dim SE As Range
    
    Set S = Range("A1")
    Set E = S
    Do Until S.Value = ""
        Set E = E.Offset(1)
        If E.Value = E.Offset(-1).Value Then
        Else
            Set SE = Range(S, E.Offset(-1))
            SE.Resize(, 4).BorderAround Weight:=xlThin
            Set S = E
        End If
    Loop
End Sub
top

動的にチェックボックスを追加削除 ― イメージコントロール上でマウスダウンでチェックボックスを追加、再度クリックで削除する
 ユーザーフォームでコントロールの動的追加削除 コントロールの動的配置 コントロールクラス ※必要パーツ:UserForm1, Image1
===== UserForm1 =====
Option Explicit

Private myChecks() As cCheckBox
Private C As Integer

Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim myCtrl As MSForms.Control
    
    C = C + 1
    ReDim Preserve myChecks(1 To C)
    Set myChecks(C) = New cCheckBox
    
    With Me
        Set myCtrl = .Controls.Add("Forms.CheckBox.1")
        With myCtrl
            .Name = "CheckBox" & C
            .Left = Image1.Left + X - 5
            .Top = Image1.Top + Y - 5
            .Width = 12
            .Height = 12
            .BackStyle = fmBackStyleTransparent
            .Caption = ""
            .Value = True
        End With
    End With
    
    Set myChecks(C).ChkBox = myCtrl
    myChecks(C).ID = C
    myChecks(C).Name = myCtrl.Name
End Sub

Private Sub UserForm_Terminate()
    Dim i As Integer
    On Error Resume Next
    For i = LBound(myChecks) To UBound(myChecks)
        Set myChecks(i) = Nothing
    Next
    Erase myChecks
End Sub

Public Sub DeleteCheckBox(ID As Integer, Namae As String)
    Me.Controls.Remove Namae
    Set myChecks(ID) = Nothing
End Sub

===== cCheckBox =====
Option Explicit

Public WithEvents ChkBox As MSForms.CheckBox

Private myID As Integer
Private myName As String

Public Property Let ID(IDNo As Integer)
    myID = IDNo
End Property

Public Property Let Name(Namae As String)
    myName = Namae
End Property

Private Sub ChkBox_Click()
    If ChkBox.Value = False Then
        UserForm1.DeleteCheckBox myID, myName
    End If
End Sub

Private Sub Class_Terminate()
    Set ChkBox = Nothing
End Sub
top

動的にテキストボックスを追加 ― 動的に追加したテキストボックスでイベントを処理する
 コントロールの動的配置 動的配置コントロールのイベント コントロールクラス ※TextBox1に数を入力、CommandButton1押下でその数のTextBoxを作成、作成されたTextBoxで値が削除されるとメッセージを表示する例
===== UserForm1 =====
Option Explicit

Private myTxt() As cTxtBox

Private Sub CommandButton1_Click()
    Dim myBox As MSForms.Control
    Dim i As Integer
    Dim X As Single, Y As Single
    Dim C As Integer
    
    KillTxtBox
    C = Val(Me.TextBox1.Value)
    ReDim myTxt(1 To C)
    
    X = 20: Y = 50
    For i = 1 To C
        Set myBox = Me.Controls.Add _
            ("Forms.TextBox.1", "txt" & i, True)
        With myBox
            .Left = X: .Top = Y
            Y = Y + .Height + 10
        End With
        
        Set myTxt(i) = New cTxtBox
        Set myTxt(i).TxtBox = myBox
    Next
    
End Sub

Private Sub KillTxtBox()
    Dim i As Integer
    
    On Error Resume Next
    For i = 1 To UBound(myTxt)
        Me.Controls.Remove myTxt(i).Name
        Set myTxt(i) = Nothing
    Next
    On Error GoTo 0
    
    Erase myTxt
End Sub

Private Sub UserForm_Terminate()
    KillTxtBox
End Sub

===== cTxtBox =====
Option Explicit

Private WithEvents Txt As MSForms.TextBox
Private Ctrl As MSForms.Control

Public Property Set TxtBox(Box As MSForms.Control)
    Set Txt = Box
    Set Ctrl = Box
End Property

Public Property Get Name() As String
    Name = Ctrl.Name
End Property

Private Sub Class_Terminate()
    Set Txt = Nothing
    Set Ctrl = Nothing
End Sub


Private Sub Txt_Change()
    If Txt.Value = "" Then
        MsgBox Ctrl.Name & ":なし"
    End If
End Sub
top

コントロールのイベントをクラスで処理 ― ユーザーフォーム上の任意の数のListBoxをクラスで一括処理する例
 コントロールイベントの一括処理 ListBoxのクラス処理 コントロールの擬似配列 ※リストボックスを2個以上配置、RowSourceなどで適当にリストデータを設定して実行する
===== UserForm1 =====
Option Explicit

Private myList() As cListBox

Private Sub UserForm_Initialize()
    Dim C As Integer
    Dim L As MSForms.Control
    For Each L In Me.Controls
        If TypeOf L Is MSForms.ListBox Then
            C = C + 1
            ReDim Preserve myList(1 To C)
            Set myList(C) = New cListBox
            Set myList(C).List = L
            Set myList(C).Ctrl = L
        End If
    Next
End Sub

Private Sub UserForm_Terminate()
    Dim i As Integer
    On Error Resume Next
    For i = LBound(myList) To UBound(myList)
        Set myList(i) = Nothing
    Next
    On Error GoTo 0
    Erase myList
End Sub

===== cListBoxクラス =====
Option Explicit

Public WithEvents List As MSForms.ListBox

'NameプロパティはListBoxクラスには含まれないため別に定義する
Public Ctrl As MSForms.Control

Private Sub List_Click()
    With List
        MsgBox .Value
    End With
    With Ctrl
        MsgBox .Name
    End With
End Sub
top

CSVをまとめる2 ― 複数のCSVファイルを一つのシートにまとめる、一括で読み込みSplitで行分割する例
 複数CSVの統合 複数ファイルの結合 テキストファイルの一括読み込み 任意の改行文字 ※合計行数は一シートの行数(Excel2002では65536)-1以内
Sub ReadCSV()
    Dim myPath As String
    Dim Fname As String
    Dim N As Integer
    Dim rngDest As Range
    Dim myArray0 As Variant
    Dim myArray As Variant
    Dim D As String
    Dim i As Integer
  
    myPath = ThisWorkbook.Path & "\"
    Set rngDest = Worksheets("Sheet1").Range("A1")
  
    Application.ScreenUpdating = False
  
    Fname = Dir(myPath & "*.csv")
    Do Until Fname = ""
        N = FreeFile
        Open myPath & Fname For Input As #N
        D = InputB(LOF(N), N)
        D = StrConv(D, vbUnicode)
        Close #N
        
        '先頭行にファイル名挿入
        'rngDest.Value = Fname
        'Set rngDest = rngDest.Offset(1)
        
        myArray0 = Split(D, vbCrLf)    '全体を行に分割
        For i = 0 To UBound(myArray0)
            myArray = Split(CStr(myArray0(i)), ",")    '各行を項目に分割
            rngDest.Resize(1, UBound(myArray) + 1).Value = myArray
            Set rngDest = rngDest.Offset(1)
        Next
        Fname = Dir()
    Loop
  
    Application.ScreenUpdating = True
    Set rngDest = Nothing
End Sub
top

CSVをまとめる ― 複数のテキストファイルをひとつにまとめる、各々タイトル行が入っていて1ファイル目のみ使う
 複数のCSVファイル結合 複数テキストファイルの統合
Sub CSVをまとめる()
    Dim myPath As String
    Dim Nin As Integer
    Dim Nout As Integer
    Dim Fname As String
    Dim D As String
    Dim Fc As Integer   'FileCount
    Dim Lc As Integer   'LineCount
    
    myPath = ThisWorkbook.Path & "\"
    Nout = FreeFile
    Open myPath & "Out.txt" For Output As #Nout
    Fname = Dir(myPath & "*.csv")
    
    Do Until Fname = ""
        Fc = Fc + 1
        Lc = 0
        Nin = FreeFile
        Open myPath & Fname For Input As #Nin
        Do Until EOF(Nin)
            Line Input #Nin, D
            Lc = Lc + 1
            '1ファイルめの1行目のみタイトルとして出力
            If Lc = 1 Then
                If Fc = 1 Then
                    Print #Nout, D
                End If
            Else
            '2行目以降はすべて出力
                Print #Nout, D
            End If
        Loop
        Close #Nin
        Fname = Dir()
    Loop
    Close #Nout
End Sub
top

シンクロ並べ替え ― 2列のデータを昇順に同期して並べ替える
 同期並べ替え 2列をシンクロ 行挿入で同期 ※MsCombSortIを使用する
B E   A A
C G   B 
D A ⇒ C C
F C   D 
A       E
      F 
        G

Sub シンクロ並べ替え()
    Dim Dic As Object
    Dim rngA As Range
    Dim rngB As Range
    Dim rngDest As Range
    Dim myCell As Range
    Dim K As String
    Dim Kys As Variant
    Dim Idx As Variant
    Dim V As Variant
    Dim i As Integer
    
    Set Dic = CreateObject("Scripting.Dictionary")
    
    Set rngA = Range("A1", Range("A65536").End(xlUp))
    Set rngB = Range("B1", Range("B65536").End(xlUp))
    Set rngDest = Range("D1")
    
    For Each myCell In rngA.Cells
        K = myCell.Value
        Dic.Item(K) = 1
    Next
    
    For Each myCell In rngB.Cells
        K = myCell.Value
        Dic.Item(K) = Dic.Item(K) + 2
    Next
    
    Kys = Dic.keys
    Idx = MsCombSortI(Kys)          'キーが文字の場合
    'Idx = MsCombSortI(StoV(Kys))    'キーが数値の場合
    
    For i = LBound(Idx) To UBound(Idx)
        K = Kys(Idx(i))
        V = Dic.Item(K)
        If V = 1 Or V = 3 Then
            rngDest.Value = K
        End If
        If V = 2 Or V = 3 Then
            rngDest.Offset(, 1).Value = K
        End If
        Set rngDest = rngDest.Offset(1)
    Next
    
    Set myCell = Nothing
    Set rngDest = Nothing
    Set rngB = Nothing
    Set rngA = Nothing
    Set Dic = Nothing
End Sub

Private Function StoV(S As Variant) As Variant
    'String()をDouble()に変換、一次元限定
    Dim V() As Double
    Dim L As Long, U As Long
    Dim i As Long
    
    L = LBound(S): U = UBound(S)
    ReDim V(L To U)
    For i = L To U
        V(i) = CDbl(S(i))
    Next
    StoV = V
End Function
top

項目名の取得 ― あるセルから上にみて、アクティブセル領域の一行目、数字でない文字のセル、罫線の下のセルなどを探す
 項目判断 罫線の下 項目名取得
===== ThisWorkbook =====
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)
    'ワークシート名と項目名でチェック
    If Sh.Name = "定価表" And 項目名3(Target) = "仕様コード" Then
        MsgBox "OK"
        Cancel = True
    End If
End Sub

Private Function 項目名(Target As Range) As String
    'アクティブセル領域の第一行めの値を返す
    Dim myCell As Range
    With Target
        Set myCell = Intersect(.CurrentRegion, .EntireColumn)
        Set myCell = myCell.Cells(1)
    End With
    項目名 = myCell.Value
End Function

Private Function 項目名2(Target As Range) As String
    '罫線で囲まれた表の第一行めの値を返す _
    '(上方向に見て、上罫線がある最初のセルの値を返す)
    Dim myCell As Range
    Set myCell = Target
    Do Until myCell.Row = 1 Or _
        myCell.Borders(xlEdgeTop).LineStyle = xlContinuous
        Set myCell = myCell.Offset(-1, 0)
    Loop
    If myCell.Borders(xlEdgeTop).LineStyle = xlContinuous Then
        項目名2 = myCell.Value
    Else
        項目名2 = ""
    End If
End Function

Private Function 項目名3(Target As Range) As String
    '上方向に見て、数字でない文字が入力されている最初のセルの値を返す
    Dim myCell As Range
    Set myCell = Target
    Do Until myCell.Row = 1 Or Not IsNumeric(myCell.Value)
        Set myCell = myCell.Offset(-1, 0)
    Loop
    If Not IsNumeric(myCell.Value) Then
        項目名3 = myCell.Value
    Else
        項目名3 = ""
    End If
End Function
top

半角英数のチェック ― 文字列が半角英数のみかそれ以外が含まれているかの確認方法
 半角英数字チェック 全角半角
Sub Test
    Msgbox 半角英数字("123abc")
    Msgbox 半角英数字("123あabc")
End Sub

Function 半角英数字(S As String) As Boolean
    If S = "" Then 半角英数字 = False: Exit Function
    If S Like "*[!A-Za-z0-9]*" Then
        半角英数字 = False
    Else
        半角英数字 = True
    End If
End Function
top

不連続セルに連番 ― SpecialCellsで値の在るセルへの参照を取得し、その個々の要素に連番を振る
 ※G列の値をチェックし「1」ならA列に連番を振る例
Sub myNumber()
    Dim rngTop As Range
    Dim rngEnd As Range
    Dim myColumn As Range
    Dim myCell As Range
    Dim C As Long
    
    Set rngTop = Range("G1")
    Set rngEnd = Range("G65536").End(xlUp)
    Set myColumn = Range(rngTop, rngEnd)
    Set myColumn = myColumn.SpecialCells(xlCellTypeConstants)
    
    C = 1
    For Each myCell In myColumn.Cells
        With myCell
            If .Value = 1 Then
                .Offset(, -6).Value = C
                C = C + 1
            End If
        End With
    Next
End Sub
top

タブ区切りテキストファイルの読み込み ― 読み込みデータをSplitで分割後、書き込み先をResizeで拡張して一行分を一度に書き込む
 タブ区切りテキストの読込み 一行毎に読み込み ※データ中の「"」はカットし、新規ブックへ読み込む例
Sub test()
    Dim myPath As String
    Dim N As Integer
    Dim LineData As String
    Dim rngDest As Range
    Dim myArray As Variant
    
    myPath = ThisWorkbook.Path & "\test.txt"
    N = FreeFile
    
    Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
    
    Open myPath For Input As #N
    
    Do While Not EOF(N)
        Line Input #N, LineData
        myArray = Split(Replace(LineData, Chr$(34), ""), vbTab)
        With rngDest.Resize(1, UBound(myArray) + 1)
            .NumberFormat = "@"
            .Value = myArray
        End With
        Set rngDest = rngDest.Offset(1)
    Loop
    
    Close #N
End Sub
top

複数ブックのシートを1シートにまとめる ― 複数のブックの複数のシートの内容を、新規ブックの1シートにコピーする
 複数ブックの統合 複数ブックの結合 複数ブックを1シートに ※このマクロブックと同一フォルダ内のブックを1シートにまとめる例
Sub Books2Sheet()
    Dim rngDest As Range
    Dim myPath As String
    Dim myBookName As String
    Dim mySheet As Worksheet
    
    myPath = ThisWorkbook.Path & "\"
    myBookName = Dir(myPath & "*.xls")
    If myBookName = "" Then Exit Sub
    
    Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
    
    Do Until myBookName = ""
        If myBookName = ThisWorkbook.Name Then
        Else
            With Workbooks.Open(myPath & myBookName)
                For Each mySheet In .Worksheets
                    With mySheet.UsedRange
                        .Copy rngDest
                        Set rngDest = rngDest.Offset(.Rows.Count)
                    End With
                Next
                .Close False
            End With
        End If
        myBookName = Dir()
    Loop
    Msgbox "完了!"
End Sub
top

列Trim ― 一列の上下の空白セルを取り除いて返す、すべて空白ならNothingを返す
 Rangeツール 列のTrim 空白セルのカット 空白削除
Sub test()
    Dim RR As Range
    Set RR = ColTrim(Selection)
    If RR Is Nothing Then
        MsgBox "Nothing"
    Else
        RR.Select
    End If
End Sub

Private Function ColTrim(ByVal RR As Range) As Range
    '一列の上下の空白セルを取り除いて返す、すべて空白ならNothingを返す
    Dim T As Range, B As Range
    If RR Is Nothing Then Exit Function
    Set RR = RR.Columns(1)
    
    Set T = RR.Cells(1)
    Set B = RR.Cells(RR.Cells.Count)
    
    If T.Value = "" Then
        Set T = T.End(xlDown)
    End If
    If B.Value = "" Then
        Set B = B.End(xlUp)
    End If
    
    If B.Row >= T.Row Then
        Set ColTrim = Range(T, B)
    Else
        Set ColTrim = Nothing
    End If
    
End Function
top

TrimTitle2 ― 表の最左列(n列)を取り去って返す
 Rangeツール 項目列削除
Sub test()
    Dim RR As Range
    Set RR = Range("A1:E5")
    TrimTitle2(RR).Select
End Sub

Private Function TrimTitle2(R As Range, Optional N As Integer = 1) As Range
    '表の左n列を取り去って返す
    Set TrimTitle2 = Intersect(R, R.Offset(,N))
End Function
top

TrimTitle ― 表の最上行(n行)を取り去って返す
 Rangeツール 項目行削除 タイトル削除 CutTitle
Sub test()
    Dim RR As Range
    Set RR = Range("A1:E5")
    TrimTitle(RR, 2).Select
End Sub

Private Function TrimTitle(R As Range, Optional N As Integer = 1) As Range
    '表の上n行を取り去って返す
    Set TrimTitle = Intersect(R, R.Offset(N))
End Function
top

基本メニューサンプル ― 既存メニューバーやショートカットメニューに自作メニューを追加する基本的な例
 コマンドバーへのメニューの追加 自作メニューの追加 メニュー作成例 ※プロジェクト、モジュール、プロシージャはユニークな名前を付けるのが基本、特にプロジェクト名は重要
===== ThisWorkbook =====
Option Explicit

Private Sub Workbook_Open()
    AddMenu
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    DeleteMenu
End Sub

===== 標準モジュール =====
Option Explicit

'要変更箇所1:プロジェクト名

Private Const MenuCaption As String = "Menu-1"  '要変更箇所2:メニュー名

Public Sub AddMenu()
    '専用メニューの追加
    Dim Ctrl As CommandBarControl
    Dim myCtrl As CommandBarControl
    Dim myBar As CommandBar
    Dim Flag As Boolean

    'ワークシートメニューバー
    With Application.CommandBars("Worksheet Menu Bar")
        Flag = False
        '専用メニューが既にあるか確認
        For Each Ctrl In .Controls
            If Ctrl.Caption = MenuCaption Then
                Flag = True
                Exit For
            End If
        Next
        If Not Flag Then
            '無い場合は追加する
            Set myCtrl = .Controls.Add(Type:=msoControlPopup, Temporary:=True)
            myCtrl.Caption = MenuCaption
            Set myBar = myCtrl.CommandBar
            AddSubMenu myBar
        End If
    End With
    
    'ショートカットメニュー(Cell)
    With Application.CommandBars("Cell")
        Flag = False
        '専用メニューが既にあるか確認
        For Each Ctrl In .Controls
            If Ctrl.Caption = MenuCaption Then
                Flag = True
                Exit For
            End If
        Next
        If Not Flag Then
            '無い場合は追加する
            Set myCtrl = .Controls.Add(Type:=msoControlPopup, Before:=1, Temporary:=True)
            .Controls(2).BeginGroup = True
            myCtrl.Caption = MenuCaption
            Set myBar = myCtrl.CommandBar
            AddSubMenu myBar
        End If
    End With
End Sub

Private Sub AddSubMenu(myBar As CommandBar) '要変更箇所3
    With myBar.Controls
        With .Add(msoControlButton, 1)
            .Caption = "SubMenuA"
            .OnAction = "SubMenuA"
        End With
        With .Add(msoControlButton, 1)
            .Caption = "SubMenuB"
            .OnAction = "SubMenuB"
        End With
        
        With .Add(msoControlButton, 1)
            .BeginGroup = True
            .Caption = "終了(&X)"
            'プロジェクト名.モジュール名.プロシージャ名 とすることを強く推奨します
            .OnAction = "Pro1.Module1.終了"
        End With
    End With
End Sub

Private Sub SubMenuA()  '要変更箇所4
    MsgBox "I am SubMenuA"
End Sub

Private Sub SubMenuB()  '要変更箇所4
    MsgBox "I am SubMenuB"
End Sub

Private Sub 終了()
    DeleteMenu
    ThisWorkbook.Close
End Sub

Public Sub DeleteMenu()
    '専用メニューの削除
    On Error Resume Next
    Application.CommandBars("Worksheet Menu Bar").Controls(MenuCaption).Delete
    Application.CommandBars("Cell").Controls(MenuCaption).Delete
    On Error GoTo 0
End Sub
top

超簡単メニューサンプル ― メニューバーにユーザ定義のメニューを追加する例
 MenuBar 簡単なメニュー例 単純なメニュー例 ユーザ定義メニュー
===== ThisWorkbookモジュール =====
Option Explicit

Private Const myBarName As String = "my&Menu"

Private Sub Workbook_Open()
    Dim myPopUp As CommandBarPopup
    Dim myBar As CommandBar
    Dim myButton As CommandBarButton
    
    DeleteMenu
    
    Set myPopUp = Application.CommandBars("Worksheet Menu Bar") _
        .Controls.Add(Type:=msoControlPopup, temporary:=True)
    With myPopUp
        .Caption = myBarName
        Set myBar = .CommandBar
    End With
    
    Set myButton = myBar.Controls.Add(Type:=msoControlButton)
    With myButton
        .Caption = "SubMenu&1"
        .OnAction = "SubMenu1"
    End With
    
    Set myButton = Nothing
    Set myBar = Nothing
    Set myPopUp = Nothing
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    DeleteMenu
End Sub

Private Sub DeleteMenu()
    On Error Resume Next
    Application.CommandBars("WorkSheet Menu Bar").Controls(myBarName).Delete
    On Error GoTo 0
End Sub

===== 標準モジュール =====
Sub SubMenu1()
    MsgBox "Hello World!"
End Sub
top

グラフをウィンドウで表示する ― グラフシートでも埋め込みグラフでもなく、ウィンドウでグラフを表示する
 グラフウィンドウ 別ウィンドウ フロートウィンドウ
Sub グラフをウィンドウで表示する()
    Dim myRange As Range
    Dim myChartOBJ As ChartObject
    
    Set myRange = ActiveCell.CurrentRegion
    
    With Charts.Add
        .ChartType = xlColumnClustered
        .SetSourceData Source:=myRange
        .Location Where:=xlLocationAsObject, _
            Name:=myRange.Worksheet.Name
    End With
    
    With myRange.Worksheet
        Set myChartOBJ = .ChartObjects(.ChartObjects.Count)
    End With
    
    With myChartOBJ
        .Chart.ShowWindow = True
        .Delete
    End With
    
End Sub
top

グラフの縦横比率を1:1にする ― グラフの縦横のスケールを1:1にし、プロットエリアを方眼紙のようにする
 グラフスケール 目盛りを正方形に 同比率目盛 方眼紙グラフ 縦横を1対1に ※散布図のみが対象
Sub グラフの縦横比率を1対1にする()
    Dim myChart As Chart
    Dim 横pP As Double
    Dim 縦pP As Double
    Dim myAxis As Axis
    
    Set myChart = ActiveChart
    With myChart
        'フォント自動サイズ調整Off
        .ChartArea.AutoScaleFont = False
        '横、単位当たりのポイント長さ
        Set myAxis = .Axes(xlCategory)
        横pP = .PlotArea.InsideWidth / (myAxis.MaximumScale - myAxis.MinimumScale)
        '縦、単位当たりのポイント長さ
        Set myAxis = .Axes(xlValue)
        縦pP = .PlotArea.InsideHeight / (myAxis.MaximumScale - myAxis.MinimumScale)
        With .PlotArea
            '長い方を短くする
            If 横pP > 縦pP Then
                '横の方が長ければ
                .Width = .Width - .InsideWidth * (1 - 縦pP / 横pP)
            Else
                '縦の方が長ければ
                .Height = .Height - .InsideHeight * (1 - 横pP / 縦pP)
            End If
        End With
    End With
End Sub
top

CountDownTimer ― ワークシートのセルにカウントダウンタイマーを表示する
Sub Start2()
    Dim myTime As Integer
    Dim i As Integer
    Dim T0 As Single
    Dim T1 As Single
    
    myTime = 60
    T0 = Timer
    
    For i = myTime To 1 Step -1
        T1 = T0 + myTime - i + 1
        Range("A1").Value = i
        Do While Timer < T1
            DoEvents
        Loop
    Next
    Range("A1").Value = 0
    MsgBox "お時間でごんす。"
End Sub
top

コンボボックスのリスト循環 ― UserFormのコンボボックスのリストアイテム選択を、矢印キーで循環させる
 コンボボックスで循環選択 リストの循環選択 ※必要パーツ:UserForm1, ComboBox1(プロパティなどで適当にリストを設定しておく)
===== UserForm1 =====
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Select Case KeyCode
        Case 40
            '下
            With Me.ComboBox1
                If .ListIndex = .ListCount - 1 Then
                    .ListIndex = 0
                    KeyCode = 0
                End If
            End With
        Case 38
            '上
            With Me.ComboBox1
                If .ListIndex = 0 Then
                    .ListIndex = .ListCount - 1
                    KeyCode = 0
                End If
            End With
    End Select
End Sub
top

一行一系列の散布図 ― 系列名、X、Yの一行で一系列の散布図
 一行一系列散布図 系列名を指定した散布図 系列名指定散布図
系列名 X Y
a   1 2
b   2 5
c   3 3
d   4 6
e   5 1

Sub CreateChart()
    Dim myChartOBJ As ChartObject
    Dim myChart As Chart
    Dim myTable As Range
    Dim L As Double
    Dim T As Double
    Dim myRow As Range
    Dim mySeries As Series
    
    '元データ
    Set myTable = Range("A2", Range("A65536").End(xlUp)).Resize(, 3)
    
    '散布図を描く場所
    With myTable
        L = .Left + .Width
        T = .Top
    End With
    
    '埋め込みグラフを作る
    Set myChartOBJ = ActiveSheet.ChartObjects.Add(L, T, 400, 400)
    Set myChart = myChartOBJ.Chart
    
    With myChart
        .ChartType = xlXYScatter    '散布図
        .ChartArea.AutoScaleFont = False
        For Each myRow In myTable.Rows
            '一行一系列
            .SeriesCollection.Add Source:=myRow
            Set mySeries = .SeriesCollection(.SeriesCollection.Count)
            '系列名、X、Y値をあらためて指定
            With mySeries
                .Name = myRow.Cells(1).Value
                .XValues = myRow.Cells(2)
                .Values = myRow.Cells(3)
            End With
        Next
    End With
    
End Sub
top

CheckTimeStamp ― 更新日付が指定期間内のファイルのリストを出力する
 更新日の確認 FileDateTime ある期間内ファイル ある日付範囲のファイル
Sub CheckTimeStamp()
    Dim myPath As String
    Dim myFname As String
    Dim myTimeStamp As Date
    Dim TimeA As Date
    Dim TimeB As Date
    
    myPath = ThisWorkbook.Path
    TimeA = #12/27/04 1:00:00 AM#
    TimeB = #12/27/04 3:00:00 AM#
    
    myFname = Dir(myPath & "\*.*")
    Do While myFname <> ""
        myTimeStamp = FileDateTime(myPath & "\" & myFname)
        If myTimeStamp >= TimeA And myTimeStamp <= TimeB Then
            Debug.Print myFname, myTimeStamp
        End If
        myFname = Dir()
    Loop
End Sub
top

Shellの処理待ち ― Shellで起動したアプリケーションが終了するまで次のステップに進まずに待つ
 Shell処理待ち 外部アプリの処理待ち 外部アプリケーションの終了待ち 実行ファイルの終了待ち
Sub test()
    With CreateObject("WScript.Shell")
        .Run "notepad.exe", , True
        MsgBox "処理1終了"
        .Run "CALC.EXE", , True
        MsgBox "処理2終了"
    End With
End Sub
top

フォルダ選択ダイアログ ― 実用的なフォルダ選択ダイアログ表示(古いマシンでもOK)
 フォルダの選択 フォルダダイアログ Folder Shell.Application
Private Sub test()
    Dim Fld As String
    'Fld = フォルダ選択
    Fld = フォルダ選択(Title:="選択してね", RootFolder:="c:\")
    If Fld = "" Then
        MsgBox "Cancel or Error", vbExclamation
    Else
        MsgBox Fld
    End If
End Sub

'選択したフォルダのフルパスを返す、キャンセル又はエラーなら""を返す
Public Function フォルダ選択(Optional Title As String = "フォルダを選択して下さい。", _
        Optional RootFolder As Variant) As String
    '参照設定するなら、Microsoft Shell Controls And Automationに
    Dim Shl As Object   'Shell32.Shell
    Dim Fld As Object   'Folder
    Dim strFld As String
    
    Set Shl = CreateObject("Shell.Application")
    '1:コントロールパネルなどの余分なもの非表示  512:新規フォルダ作成ボタン非表示
    If IsMissing(RootFolder) Then
        Set Fld = Shl.BrowseForFolder(0, Title, 1 + 512)
    Else
        Set Fld = Shl.BrowseForFolder(0, Title, 1 + 512, RootFolder)
    End If
    
    strFld = ""
    If Not Fld Is Nothing Then
        On Error Resume Next
        strFld = Fld.Self.Path
        If strFld = "" Then
            strFld = Fld.Items.Item.Path
        End If
        On Error GoTo 0
    End If
    
    If InStr(strFld, "\") = 0 Then strFld = ""
    
    フォルダ選択 = strFld
    
    Set Fld = Nothing
    Set Shl = Nothing
End Function
top

図形内のテキスト置き換え
 図形テキスト置換え
Sub ReplaceText()
    Dim myShape As Shape
    Const Org As String = "Text"
    Const After As String = "テキスト"
    Dim i As Integer
    
    On Error Resume Next
    For Each myShape In ActiveSheet.Shapes
        With myShape.TextFrame.Characters
            i = InStr(.Text, Org)
            If i >= 1 Then
                .Text = Left$(.Text, i - 1) & After & Mid$(.Text, i + Len(Org))
            End If
        End With
    Next
    On Error GoTo 0
    
    Set myShape = Nothing
End Sub
top

ユーザー定義ツールバーの制御 ― ブックに添付したツールバー(ユーザー定義コマンドバー)のON、OFF(表示、非表示)を制御する
 ブック添付のツールバー制御 ブック添付ツールバーの制御 ツールバーの表示非表示制御
===== ThisWorkbookモジュール =====
'ブックに添付したツールバーの名前
Private Const myBarName As String = "myBar"

Private myBar As CommandBar

Private Sub Workbook_Open()
    Set myBar = Application.CommandBars(myBarName)
    myBar.Visible = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    myBar.Delete
    Set myBar = Nothing
End Sub

Private Sub Workbook_Activate()
    myBar.Visible = True
End Sub

Private Sub Workbook_Deactivate()
    On Error Resume Next
    myBar.Visible = False
    On Error GoTo 0
End Sub
top

CSVの引用符付き保存 ― CSVファイルをダブルクリックで開き編集、それを「"」付きCSVで再び保存する、右クリックメニューから実行する
 CSVの直接編集 CSVの"付き保存
===== ThisWorkbook =====
Option Explicit

Private myButtonName As String

Private Sub Workbook_Open()
    Dim myButton As CommandBarButton
    
    myButtonName = """" & "付きCSV保存"
    
    With Application.CommandBars("Cell")
        Set myButton = .Controls.Add(before:=1, temporary:=True)
        With myButton
            .Caption = myButtonName
            .OnAction = "二重引用符付きCSVで保存"
        End With
        .Controls(2).BeginGroup = True
    End With
    
    Set myButton = Nothing
    
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Cell").Controls(myButtonName).Delete
    On Error GoTo 0
End Sub

===== 標準モジュール =====
Sub 二重引用符付きCSVで保存()
    Dim myPath As String
    Dim tmpPath As String
    Dim N As Integer
    Dim myRange As Range
    Dim i As Long
    Dim j As Long
    Dim Qt As String
    
    Qt = Chr$(34)
    
    Set myRange = ActiveSheet.UsedRange
    
    With myRange
        myPath = .Worksheet.Parent.FullName
        tmpPath = .Worksheet.Parent.Path & "\Temp.csv"
        
        N = FreeFile
        Open tmpPath For Output As #N
        
        For i = 1 To .Rows.Count
            Print #N, Qt; .Cells(i, 1).Text; Qt;
            For j = 2 To .Columns.Count
                Print #N, ","; Qt; .Cells(i, j).Text; Qt;
            Next j
            Print #N, ""
        Next i
        
        Close #N
        .Worksheet.Parent.Close False
        Kill myPath
        Name tmpPath As myPath
    End With
    
End Sub
top

CommandBarComboBoxの使用例 ― フォントサイズ変更用ドロップダウンリストのようなコンボボックスをメニューバーに追加する例
 メニューバーにドロップダウンリスト追加 ツールバーに選択リスト追加 コマンドバーでドロップダウンリスト使用 コマンドバーコンボボックス
Option Explicit

Private Const CombName As String = "学校List"

Sub Sett()
    Dim myList As CommandBarComboBox
    Set myList = Application.CommandBars("Worksheet Menu Bar"). _
        Controls.Add(Type:=msoControlComboBox, Temporary:=True)
    With myList
        .Caption = CombName
        .AddItem "小学校"
        .AddItem "中学校"
        .AddItem "高等学校"
        .OnAction = "Exec"
    End With
End Sub

Sub Resett()
    On Error Resume Next
    Application.CommandBars("Worksheet Menu Bar").Controls(CombName).Delete
    On Error GoTo 0
End Sub

Sub Exec()
    MsgBox CommandBars.ActionControl.Text
End Sub
top

SumFiles ― フォルダ内の複数のブックをひとつの新規ブックにまとめる、全シートを丸ごとコピーする形で
 複数ブックの結合 複数ブック統合
Sub SumFiles()
    Dim myBook As Workbook
    Dim destBook As Workbook
    Dim myName As String
    Dim myPath As String
    
    Set destBook = Workbooks.Add
    
    myPath = "フォルダA\"
    myName = Dir(myPath & "10*.xls")
    Do While myName <> ""
        Set myBook = Workbooks.Open(myPath & myName)
        myBook.Worksheets.Copy destBook.Worksheets(1)
        myBook.Close False
        myName = Dir()
    Loop
    
    Set myBook = Nothing
    Set destBook = Nothing
End Sub
top

グループ処理2 ― 同一データ(グループ)毎の処理
 グループ毎の処理 同データ毎の処理 同一データ毎の処理
Sub グループ処理2() '※終了条件=""
    Dim S As Range
    Dim E As Range
    
    Set S = Range("A2")
    Set E = S
    
    Do Until S.Value = ""
        Set E = E.Offset(1)
        If E.Value = E.Offset(-1).Value Then
        Else
            Debug.Print S.Row, E.Offset(-1).Row
            Set S = E
        End If
    Loop
End Sub

Sub グループ処理3() '※終了条件=最終行
    Dim S As Range
    Dim E As Range
    Dim maxRow As Long
    
    maxRow = Range("A65536").End(xlUp).Row
    Set S = Range("A2")
    Set E = S
    
    Do Until S.Row > maxRow
        Set E = E.Offset(1)
        If E.Value = E.Offset(-1).Value Then
        Else
            Debug.Print S.Row, E.Offset(-1).Row
            Set S = E
        End If
    Loop
End Sub

Sub グループ処理4() '※配列の場合
    Dim S As Long
    Dim E As Long
    Dim Ary As Variant
    Dim Flg As Boolean
    
    Ary = Array(1, 2, 2, 3, 3, 3, 4)
    S = LBound(Ary)
    E = S
    
    Do Until S > UBound(Ary)
        E = E + 1
        If E > UBound(Ary) Then
            Flg = True
        Else
            If Ary(E) = Ary(E - 1) Then
                Flg = False
            Else
                Flg = True
            End If
        End If
        
        If Flg Then
            Debug.Print S, E - 1
            S = E
        End If
    Loop
End Sub
top

クラス毎の関数挿入 ― 連続した同一データ(学年&クラスでソート済み)の下に行を挿入してワークシート関数を設定する
 同一グループ毎に関数挿入 行間への関数の挿入 クラス毎に関数の設定
学年 クラス 名前   成績
1   1   日本太郎 90
1   2   平成次郎 75
1   2   日本花子 66
3   1   平成花子 47
5   3   村木美子 100
5   3   山田一郎 99
  ↓    
学年 クラス 名前   成績
1  1    日本太郎 90
       平均   90
       最高   90
       標準偏差 0
1  2    平成次郎 75
1  2    日本花子 66
       平均   70.5
       最高   75
       標準偏差 4.5
3  1    平成花子 47
       平均   47
       最高   47
       標準偏差 0
5  3    村木美子 100
5  3    山田一郎 99
       平均   99.5
       最高   100
       標準偏差 0.5

Sub クラス毎関数挿入()
    Dim rngTop As Range
    Dim rngBottom As Range
    Dim rngCalc As Range
    
    Set rngTop = Range("A2")
    Set rngBottom = rngTop
    
    Do Until rngTop.Value = ""
        Set rngBottom = rngBottom.Offset(1)
        
        With rngBottom
            If .Value = .Offset(-1, 0).Value And _
                .Offset(0, 1).Value = .Offset(-1, 1).Value Then
                'nop
            Else
                '3行挿入
                .Resize(3).EntireRow.Insert
                '計算対象範囲
                Set rngCalc = Range(rngTop, .Offset(-4)).Offset(, 3)
                '平均
                .Offset(-3, 2).Formula = "平均"
                .Offset(-3, 3).Formula = "=AVERAGE(" & rngCalc.Address(0, 0) & ")"
                '最高
                .Offset(-2, 2).Formula = "最高"
                .Offset(-2, 3).Formula = "=MAX(" & rngCalc.Address(0, 0) & ")"
                '標準偏差
                .Offset(-1, 2).Formula = "標準偏差"
                .Offset(-1, 3).Formula = "=STDEVP(" & rngCalc.Address(0, 0) & ")"
                
                Set rngTop = rngBottom
            End If
        End With
    Loop
    
    Set rngTop = Nothing
    Set rngBottom = Nothing
    Set rngCalc = Nothing
End Sub
top

列の値を行方向に整列 ― 元表を下から順に見て、右側(3列目以降)に値が在れば、1行挿入して値をコピーする
 縦に整列 縦に並べ替え 行方向に並べ替え
111 aaa bbb
222 ccc
333 ddd eee fff ggg
444 hhh iii
555 jjj
  ↓
111 aaa
111 bbb
222 ccc
333 ddd
333 eee
333 fff
333 ggg
444 hhh
444 iii
555 jjj

Sub Sort()
    Dim myColumn As Range
    Dim myCell As Range
    Dim Temp As Range
    Dim C As Long
    Dim i As Long
    Dim j As Long
    
    Set myColumn = ActiveSheet.UsedRange.Columns(1)
    For i = myColumn.Rows.Count To 1 Step -1
        Set myCell = myColumn.Cells(i)
        With myCell
            Set Temp = .End(xlToRight)
            C = Temp.Column - .Column - 1
            If C >= 1 Then
                .Offset(1, 0).EntireRow.Resize(C).Insert
                For j = 1 To C
                    .Offset(j, 0).Value = .Value
                    .Offset(j, 1).Value = .Offset(0, j + 1).Value
                    .Offset(0, j + 1).Value = ""
                Next
            End If
        End With
    Next
End Sub
top

縦横並べ替え ― 縦にグループ毎(スタート〜エンド)に並んだデータを、横に並べ替える
 縦横並替え グループ毎の処理 並び替え
A1:A15 ==> B1:F4
   A   B C D E F
1 スタート あ い う え お
2 あ    あ   う   お
3 う    あ い う え
4 お      い     お
5 エンド
6 スタート
7 あ
8 え
9 い
10 う
11 エンド
12 スタート
13 い
14 お
15 エンド

Sub グループ毎に縦から横に並べ替え()
    Dim A As Variant, B As Variant
    Dim V As Variant
    Dim i As Integer
    Dim Dic As Object
    Dim R As Integer, C As Integer
    
    '処理データ取得
    A = Range("A1", Range("A1").End(xlDown)).Value

    '各データに対する列番号を設定
    B = Csort2(A)   '並べ替え
    Set Dic = CreateObject("Scripting.Dictionary")
    C = 1
    For i = 1 To UBound(B)
        V = B(i, 1)
        Select Case V
            Case "スタート", "エンド"
            Case Else
                If Not Dic.Exists(V) Then
                    C = C + 1
                    Dic.Item(V) = C
                End If
        End Select
    Next
    
    '総括(項目行)表示
    Cells(1, 2).Resize(1, Dic.Count).Value = Dic.Keys
    
    '各データ表示
    R = 1
    For i = 1 To UBound(A)
        V = A(i, 1)
        Select Case V
            Case "スタート"
                R = R + 1
            Case "エンド"
            Case Else
                Cells(R, Dic.Item(V)).Value = V
        End Select
    Next
    
    Set Dic = Nothing
End Sub

Private Function Csort2(ByVal Ary As Variant) As Variant
'1列のみの2次元配列(シートの列データ)並べ替え
    Dim L As Long
    Dim U As Long
    Dim i As Long
    Dim gap As Long
    Dim Temp As Variant
    Dim F As Boolean
    
    L = LBound(Ary)
    U = UBound(Ary)
    gap = U - L
    F = True
    
    Do While gap > 1 Or F = True
        gap = Int(gap / 1.3)
        If gap = 9 Or gap = 10 Then
            gap = 11
        ElseIf gap < 1 Then
            gap = 1
        End If
        F = False
        For i = L To U - gap
            If Ary(i, 1) > Ary(i + gap, 1) Then
                Temp = Ary(i, 1)
                Ary(i, 1) = Ary(i + gap, 1)
                Ary(i + gap, 1) = Temp
                F = True
            End If
        Next
    Loop
    
    Csort2 = Ary
End Function
top

重複無しで抽出 ― 配列から重複を除いた値を取り出す(フィルタオプションを使わず、ソート関数を使用)
 ユニーク値抽出 ユニークな値の取り出し 効率的な配列拡張法 配列エラー処理 ※ソート関数 for ExcelVBAに参照設定、もしくは他のソート関数を使用する
Sub test()
    Dim myList As Variant
    Dim List2() As String
    Dim c As Long
    Dim i As Long
    
    '元データ
    myList = ActiveSheet.UsedRange.Columns(1).Value   '※1列のデータでもセルから取得したものは2次元配列である
    '昇順に並べ替え
    myList = msQsort(myList)
    
    c = 1
    '入れ替え先の大きさはとりあえず適当
    ReDim List2(1 To 10)
    '1つめのデータ
    List2(c) = myList(1, 1)
    
    On Error GoTo RedimTrap
    For i = 2 To UBound(myList)
        '前のデータと違っていればユニークとして入れ替え先に追加する
        If myList(i, 1) <> myList(i - 1, 1) Then
            c = c + 1
            List2(c) = myList(i, 1)
        End If
    Next
    '入れ替え先の配列の、最終的な大きさを整える
    ReDim Preserve List2(1 To c)
    On Error GoTo 0
    
    For i = 1 To UBound(List2)
        Debug.Print List2(i)
    Next
    
    Exit Sub
    
'配列の拡張を効率的に行なうためのエラートラップ
RedimTrap:
    If Err.Number = 9 Then
        ReDim Preserve List2(1 To UBound(List2) * 2)
        Resume
    Else
        Stop
    End If
End Sub
top

任意の位置に文字表示 ― ワークシート上の指定位置にテキストボックスで文字を描く
 ワークシートに任意文字 任意の位置にテキストボックス
Sub CallTest()
    PutCharacter 100, 100, "100,100"
    PutCharacter 100, 200, "100,200"
End Sub

Sub PutCharacter(Left As Single, Top As Single, Chara As String)
    Dim myText As Shape
    
    Set myText = ActiveSheet.Shapes.AddTextbox _
        (msoTextOrientationHorizontal, Left, Top, 10, 10)
    With myText
        With .TextFrame.Characters
            .Text = Chara
            .Font.Name = "MS Pゴシック"
            .Font.Size = 11
        End With
        .TextFrame.AutoSize = True
    End With
    
    Set myText = Nothing
End Sub
top

新ファイル監視 ― あるフォルダに新しいファイルが作成されるのを監視し、作成されたらそれを処理する
 新規ファイルの監視 新ファイルの監視 ファイル監視
Sub WatchNewFile()
    Const Pathh As String = "C:\Documents and Settings\user name\My Documents\"
    Dim Fn As String
    Dim myList As Variant
    Static myList0 As Variant
    Dim myList0_C As Long
    Dim i As Long
    Dim j As Long
    Dim FF As Boolean
    
    '現在のリスト取得
    Fn = Dir(Pathh & "*.txt")
    Do While Fn <> ""
        i = i + 1
        If i = 1 Then
            ReDim myList(1 To 1)
        Else
            ReDim Preserve myList(1 To i)
        End If
        myList(i) = Fn
        Fn = Dir()
    Loop
    
    On Error Resume Next
    myList0_C = UBound(myList0)
    On Error GoTo 0
    
    '現在のリストのファイル名を
    For i = 1 To UBound(myList)
        FF = False
        '前回のリスト中から検索し
        For j = 1 To myList0_C
            If myList0(j) = myList(i) Then
                FF = True
                Exit For
            End If
        Next
        '無ければ(つまり新しいファイルなら)
        If FF = False Then
            '処理実行
            Debug.Print myList(i)
        End If
    Next
    
    'リスト保存
    myList0 = myList
    
    '次回起動指定
    Application.OnTime Now() + TimeValue("00:00:05"), "WatchNewFile"
End Sub
top

他のブックのイベント ― 開いているブックすべてのイベント処理を一括で行なう(マクロ未搭載ブックのイベント処理)
 他ブックのイベント エクセル全体のイベント 一括イベント処理 マクロ未記入ブックでイベント処理 アプリケーションレベルのイベント処理
===== ThisWorkbook =====
Option Explicit

Private WithEvents myExcel As Application

Private Sub myExcel_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    With Sh
        MsgBox "BookName:" & .Parent.Name & vbCrLf & _
            "SheetName:" & .Name & vbCrLf & _
            "RangeAddress:" & Target.Address
    End With
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set myExcel = Nothing
End Sub

Private Sub Workbook_Open()
    Set myExcel = Application
End Sub
top

CSVを文字列として読み込み ― CSVファイルの0付き数字をそのまま読み込む為にセル書式を文字列にして読み込む
 CSV読み込み CSVファイル読込み 文字列で読み込み 文字列で読込み セル書式変更
Sub ReadCSV()
    Dim myPath As String
    Dim N As Integer
    Dim D As String
    Dim myVals As Variant
    Dim rngDest As Range
    Dim i As Integer
    
    '読み込みファイル
    myPath = ThisWorkbook.Path & "\test.csv"
    N = FreeFile
    
    '列数確認
    Open myPath For Input As #N
    Line Input #N, D
    Close #N
    myVals = Split(D, ",")
    
    Application.ScreenUpdating = False
    
    '書き込み先
    Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
    
    '全列共、書式を文字列に設定
    rngDest.Resize(, UBound(myVals) + 1).EntireColumn.NumberFormat = "@"
    
    Open myPath For Input As #N
    
    '読み込み
    Do Until EOF(N)
        Line Input #N, D
        myVals = Split(D, ",")
        rngDest.Resize(, UBound(myVals) + 1).Value = myVals
        Set rngDest = rngDest.Offset(1)
    Loop
    
    Close #N
    
    Application.ScreenUpdating = True
End Sub
top

パスワード入力サンプル ― ユーザーフォームによるパスワード入力
 PassWord UserForm ※必要パーツ:frmPassWord, TextBox1, cmdOK, cmdキャンセル
===== frmPassWord =====
Option Explicit

Public ClickedButton As Integer

Private Sub UserForm_Initialize()
    ClickedButton = vbCancel
End Sub

Private Sub cmdOK_Click()
    With Me.TextBox1
        If .Value <> "abc" Then
            MsgBox "NG", vbExclamation
            .Value = ""
            .SetFocus
        Else
            ClickedButton = vbOK
            Me.Hide
        End If
    End With
End Sub

Private Sub cmdキャンセル_Click()
    ClickedButton = vbCancel
    Me.Hide
End Sub

===== 標準モジュール =====
Sub InputPassWord()
    With frmPassWord
        .Show
        If .ClickedButton = vbOK Then
            Unload frmPassWord
            MsgBox "PassWord OK"
        Else
            Unload frmPassWord
            MsgBox "Cancel"
        End If
    End With
End Sub
top

シート上のフォームのスピンボタンの値を循環させる
 フォームツールバーのスピンボタン スピンの値循環 ※スピンボタンに「マクロの登録」で下記プロシージャを登録する
Sub SpinTest()
    Dim myTable As Range
    Dim mySpin As Shape
    Dim L As Long
    Dim U As Long
    Dim i As Long
    
    '表示データ
    Set myTable = Worksheets("Sheet2").UsedRange.Columns(1)

    L = 1
    U = myTable.Rows.Count
    
    Set mySpin = ActiveSheet.Shapes("スピン 1")
    i = mySpin.ControlFormat.Value
    
    '範囲を超えていたら戻して循環
    If i < L Then
        i = U
    ElseIf i > U Then
        i = L
    End If
    
    mySpin.ControlFormat.Value = i
    '反転(ex. 2〜13 ---> 13〜2)
    i = U - i + L

    '値表示
    Range("A1").Value = myTable.Cells(i, 1).Value
End Sub
top

WSHのPopupサンプル ― メッセージボックスを表示後、応答が無ければ3秒で自動的に閉じる
 WindowsScriptingHost 自動で閉じるメッセージボックス 自動的に閉じる 時間で閉じる
Sub test()
    Dim WSHShell As Object
    Dim Ans As Integer
    
    Set WSHShell = CreateObject("WScript.Shell")
    Ans = WSHShell.Popup("3秒で終了します。取り消しますか?", 3, "終了取り消し", vbYesNo)
    Set WSHShell = Nothing
    
    If Ans = vbYes Then
        MsgBox "終了を取り消しました。"
    Else
        MsgBox "終了します。"
    End If

End Sub
top

ReadCsv2 ― CSVファイルの任意の指定列のみを文字列として読み込む、任意の改行コード対応版
 指定列の読み込み 任意列取り込み 任意改行コード vbLf 一括読み込み
Sub ReadCSV2()
    'CSVファイルの任意の列を文字列として読み込む(改行コード任意の例)
    Dim myPath As String
    Dim N As Integer
    Dim D As String
    Dim Vin As Variant
    Dim i As Long, j As Integer
    Dim V As Variant
    Dim Ary As Variant
    Dim Vout() As String
    Dim rngOut As Range
    Const Cr As String = vbCrLf '改行コードは、vbLf, "!" など何でも良い
    
    myPath = ThisWorkbook.Path & "\test.csv"
    Ary = Array(1, 3, 5)    '取出す列、1から数える
    Set rngOut = Range("A2")
    
    N = FreeFile
    Open myPath For Input As #N
    D = InputB(LOF(N), N)
    Close #N
    D = StrConv(D, vbUnicode)
    '最後が改行コードならカットする
    If Right$(D, Len(Cr)) = Cr Then
        D = Left$(D, Len(D) - Len(Cr))
    End If
    Vin = Split(D, Cr)
    
    ReDim Vout(1 To UBound(Vin) + 1, 1 To UBound(Ary) + 1)
    
    For i = 1 To UBound(Vin) + 1
        V = Split(CStr(Vin(i - 1)), ",")
        For j = 1 To UBound(Ary) + 1
            Vout(i, j) = V(Ary(j - 1) - 1)
        Next
    Next
    
    With rngOut.Resize(UBound(Vout), UBound(Vout, 2))
        .NumberFormat = "@"
        .Value = Vout
    End With
    
    Erase Vin, Vout
End Sub
top

ReadCSV ― CSVファイルの読み込み、特定列を読み込まない例
 CSVファイル 特定列削除 読み込み書式設定
Sub ReadCSV()
    Dim myPath As String
    Dim N As Integer
    Dim L As String
    Dim A As Variant
    Dim i As Integer
    Dim rngDest As Range
    
    myPath = ThisWorkbook.Path & "\test.csv"
    N = FreeFile
    
    Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
    '列書式設定
    With rngDest.Worksheet
        .Columns("A:C").NumberFormat = "@"
        .Columns(10).NumberFormat = "@"
    End With
    
    Open myPath For Input As #N
    Do While Not EOF(N)
        Line Input #N, L
        A = Split(L, ",")
        For i = 0 To UBound(A)
            Select Case i +1
                Case 3, 10
                    '削除
                Case Else
                    rngDest.Offset(0, i).Value = A(i)
            End Select
        Next
        Set rngDest = rngDest.Offset(1, 0)
    Loop
    Close #N
End Sub
top

チェックボックスの代わりに右クリック ― A列に値があり、B列をクリックすると「レ」「-」を交互表示する
 チェックボックス代わり 右クリックでONOFF 右クリックで切り替え ※B列のセル書式:「;"レ";"-"」
===== ThisWorkbook =====
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim myCell As Range
    Dim myRange As Range
    
    With Target
        '二列以上選択していたら
        If .Columns.Count >= 2 Then Exit Sub
        'B列以外だったら
        If .Column <> 2 Then Exit Sub
        
        '処理対象範囲をシートの使用範囲との交わり部分とする
        Set myRange = Intersect(.Cells, Sh.UsedRange)
        If myRange Is Nothing Then Exit Sub
        
        If .Rows.Count = Sh.Rows.Count Then
            '列クリックならリセット
            For Each myCell In myRange
                With myCell
                    If .Offset(0, -1).Value = "" Then
                        '左の列が空白なら
                        .Value = ""
                    End If
                End With
            Next
        Else
            '列クリックでなければ
            For Each myCell In myRange
                With myCell
                    If .Offset(0, -1).Value = "" Then
                        '左の列が空白なら
                        .Value = ""
                    Else
                        'そうでなければTrue False 切り替え
                        .Value = Not .Value
                    End If
                End With
            Next
        End If
    End With
    Cancel = True
End Sub
top

リストボックスのリストをアップダウン ― リストボックス内の選択項目を、コマンドボタンで上下に移動(タブオーダーの設定ダイアログ風)
 ユーザーフォーム リスト並べ替え 項目並べ替え 項目移動 ※必要パーツ:cmd下へ, cmd上へ, lstFileNames
===== UserForm1 =====
Private Sub cmd下へ_Click()
    Dim myValue As Variant
    Dim myIndex As Integer
    
    With Me.lstFileNames
        myIndex = .ListIndex
        If myIndex = -1 Then Exit Sub
        If myIndex = .ListCount - 1 Then Exit Sub
        myValue = .List(myIndex)
        .RemoveItem myIndex
        .AddItem myValue, myIndex + 1
        .ListIndex = myIndex + 1
    End With
End Sub

Private Sub cmd上へ_Click()
    Dim myValue As Variant
    Dim myIndex As Integer
    
    With Me.lstFileNames
        myIndex = .ListIndex
        If myIndex = -1 Then Exit Sub
        If myIndex = 0 Then Exit Sub
        myValue = .List(myIndex)
        .RemoveItem myIndex
        .AddItem myValue, myIndex - 1
        .ListIndex = myIndex - 1
    End With
End Sub

Private Sub UserForm_Initialize()
    Dim myList As Variant
    Dim L As Variant
    
    myList = Array("a", "b", "c", "d", "e")
    For Each L In myList
        Me.lstFileNames.AddItem L
    Next
End Sub
top

常に左上隅に表示 ― 表示したい範囲をカメラ機能で撮り図形で貼付け(前準備)、Selection_Change時に左上隅に移動する
 スクロール 固定 ※「図 1」を常に左上隅に表示する
===== Sheet1 =====
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    Dim L As Long
    Dim T As Long
    
    With ActiveWindow.ActivePane
        L = Columns(.ScrollColumn).Left
        T = Rows(.ScrollRow).Top
    End With
    
    With ActiveSheet.Shapes("図 1")
        .Left = L
        .Top = T
    End With
End Sub
top

図形でチェックボックス ― シート上で図形の○などをチェックボックス代わりに使用する(値の保持はセルにて)
 図形のチェックボックス 図形チェックボックス 図形代用チェックボックス Application.Caller ※適当な図形をシート上に描き、下記プロシージャを「マクロの登録」する
Sub myCheckBox()
    Dim myShp As Shape
    Set myShp = ActiveSheet.Shapes(Application.Caller)
    With myShp.TopLeftCell.Offset(0, 2)
        If .Value = False Then
            .Value = True
            myShp.Line.Visible = msoTrue
        Else
            .Value = False
            myShp.Line.Visible = msoFalse
        End If
    End With
End Sub
top

最新CSV取得 ― 特定フォルダ中の最新の更新日付のファイルを探す
 最新更新日付 最新ファイル 最新日 ファイル更新日 FileDateTime
Sub GetNewCSV()
    Dim myPath As String
    Dim myName As String
    Dim tmpName As String
    Dim myDate As Date
    Dim tmpDate As Date
    
    myPath = ThisWorkbook.Path & "\"
    
    myName = Dir(myPath & "*.csv")
    If myName = "" Then Exit Sub
    
    myDate = FileDateTime(myPath & myName)
    
    tmpName = Dir()
    Do Until tmpName = ""
        tmpDate = FileDateTime(myPath & tmpName)
        If tmpDate > myDate Then
            myName = tmpName
            myDate = tmpDate
        End If
        tmpName = Dir()
    Loop
    
    MsgBox myPath & myName & vbLf & myDate
    
End Sub
top

安定化コムソート ― コムソートの改良版、インデックスを返す、どんなデータに対しても平均的にそこそこ速い、安定
 コムソート CombSort 並べ替え 櫛ソート インデックスを返す 安定ソート
Private Sub test()
    Dim A As Variant
    Dim Idx As Variant
    Dim i As Integer
    
    A = Array(6, 2, 4, 1, 7, 4, 9, 8, 4, 3, 7, 2, 5, 6, 4, 9, 1, 3, 2)
    Idx = MsCombSortI(A)
    For i = LBound(A) To UBound(A)
        Debug.Print A(Idx(i));
    Next
    Debug.Print
    
End Sub

Private Function MsCombSortI(Ary As Variant) As Variant
    '昇順インデックスを返す
    '配列引数Aryは1次元限定
    Dim Idx() As Long
    Dim L As Long
    Dim U As Long
    Dim i As Long
    Dim gap As Long
    Dim Temp As Long
    Dim F As Boolean
    
    L = LBound(Ary)
    U = UBound(Ary)
    
    'インデックス初期設定
    ReDim Idx(L To U)
    For i = L To U
        Idx(i) = i
    Next
    
    gap = U - L
    F = True
    
    '並べ替え
    Do While gap > 1 Or F = True
        gap = Int(gap / 1.3)
        If gap = 9 Or gap = 10 Then
            gap = 11
        ElseIf gap < 1 Then
            gap = 1
        End If
        F = False
        For i = L To U - gap
            If Ary(Idx(i)) > Ary(Idx(i + gap)) Then  '降順時は <
                Temp = Idx(i)
                Idx(i) = Idx(i + gap)
                Idx(i + gap) = Temp
                F = True
            ElseIf Ary(Idx(i)) = Ary(Idx(i + gap)) Then
                If Idx(i) > Idx(i + gap) Then   '昇順降順変更しても変更の必要なし
                    Temp = Idx(i)
                    Idx(i) = Idx(i + gap)
                    Idx(i + gap) = Temp
                    F = True
                End If
            End If
        Next
    Loop

    MsCombSortI = Idx()
End Function

Private Sub セル範囲並べ替え()
    Const 列 As Integer = 1
    Dim A As Variant
    Dim B As Variant
    Dim C As Variant
    Dim myRange As Range
    Dim Idx As Variant
    Dim L As Long
    Dim U As Long
    Dim L2 As Long
    Dim U2 As Long
    Dim i As Long
    Dim j As Long
    
    Set myRange = ActiveCell.CurrentRegion
    A = myRange.Value
    
    L = LBound(A)
    U = UBound(A)
    L2 = LBound(A, 2)
    U2 = UBound(A, 2)
    
    '2次元⇒1次元
    ReDim B(L To U)
    For i = L To U
        B(i) = A(i, 列)
    Next
    
    '並べ替えインデックスを得る
    Idx = MsCombSortI(B)
    
    '配列内で並べ替え
    ReDim C(L To U, L2 To U2)
    For i = L To U
        For j = L2 To U2
            C(i, j) = A(Idx(i), j)
        Next
    Next
    
    'セルに書き戻し
    myRange.Value = C
    
    Set myRange = Nothing
End Sub
top

コムソート ― バブルソートの改良版、高速、どんなデータに対しても平均的に速い、安定ソートではない
 コムソート CombSort 並べ替え 櫛ソート
Sub test()
    Dim A As Variant
    Dim i As Integer
    
    A = Array(4, 2, 1, 7, 8, 4, 2, 5, 9)
    A = Csort(A)
    For i = LBound(A) To UBound(A)
        Debug.Print A(i);
    Next
    Debug.Print
    
End Sub

Private Function Csort(ByVal Ary As Variant) As Variant
    '昇順並べ替え、引数は1次元配列のみ可
    Dim L As Long
    Dim U As Long
    Dim i As Long
    Dim gap As Long
    Dim Temp As Variant
    Dim F As Boolean
    
    L = LBound(Ary)
    U = UBound(Ary)
    gap = U - L
    F = True
    
    Do While gap > 1 Or F = True
        gap = Int(gap / 1.3)
        If gap = 9 Or gap = 10 Then
            gap = 11
        ElseIf gap < 1 Then
            gap = 1
        End If
        F = False
        For i = L To U - gap
            If Ary(i) > Ary(i + gap) Then
                Temp = Ary(i)
                Ary(i) = Ary(i + gap)
                Ary(i + gap) = Temp
                F = True
            End If
        Next
    Loop
    
    Csort = Ary
End Function
top

挿入ソート ― ほとんど並べ替え出来ている場合は超高速、逆順だと使い物にならぬほど低速
 挿入ソート InsertSort 並べ替え 安定ソート ※アルゴリズム:左側はソート済として,ソートが済んでいないその一つ右のものをソート済の中に挿入する
Sub Isort()
    Dim A As Variant
    Dim i As Long
    Dim j As Long
    Dim Temp As Variant
    
    A = Array(5, 3, 2, 7, 5, 6, 4, 2, 9, 7)
    
    For i = LBound(A) + 1 To UBound(A)
        Temp = A(i)
        For j = i - 1 To LBound(A) Step -1
            If A(j) > Temp Then
                A(j + 1) = A(j)
            Else
                Exit For
            End If
        Next j
        A(j + 1) = Temp
    Next i
    
    For i = LBound(A) To UBound(A)
        Debug.Print A(i);
    Next
    Debug.Print
    
End Sub
top

シェルソート ― 引数の値そのものを並べ替える、1次元配列のみ可、安定ソートではない
 シェルソート 並べ替え
Private Sub MsShell(Ary As Variant)
    'シェルソート
    '引数の値そのものを昇順に並べ替える、1次元配列のみ可
    Dim L As Long
    Dim U As Long
    Dim N As Long
    Dim i As Long
    Dim j As Long
    Dim Temp As Variant
    Dim D() As Long
    Dim DD As Long
    Dim k As Long
    
    L = LBound(Ary)
    U = UBound(Ary)
    N = U - L + 1
    
    '比較間隔の配列準備
    ReDim D(1 To 19)    '19番目は約6億なのでこれで充分
    D(1) = 1
    i = 1
    Do
        Temp = D(i) * 3 + 1
        If Temp < N Then
            i = i + 1
            D(i) = Temp
        Else
            Exit Do
        End If
    Loop
    ReDim Preserve D(1 To i)
    
    '並べ替え
    For k = UBound(D) To 1 Step -1
        DD = D(k)
        For i = L To U - DD
            j = i
            Do While Ary(j) > Ary(j + DD)
                Temp = Ary(j)
                Ary(j) = Ary(j + DD)
                Ary(j + DD) = Temp
                j = j - DD
                If j < L Then Exit Do
            Loop
        Next i
    Next k

End Sub
top

シート並べ替え ― シート名を文字として並べ替える例と、数値として並べ替える例
 シート 並べ替え バブルソート
Sub シート並べ替え()
    '2シートめ以降を文字としてソート
    Dim A() As String
    Dim C As Integer
    Dim i As Integer
    
    C = Sheets.Count
    ReDim A(2 To C)
    
    For i = 2 To C
        A(i) = Sheets(i).Name
    Next
    
    Bsort_LtoU A
    
    For i = 2 To C
        Sheets(A(i)).Move after:=Sheets(C)
    Next
    
End Sub

Sub シート並べ替え2()
    '並べ替え対象シートは2シートめ以降でシート名は数字限定
    Dim A() As Long
    Dim C As Integer
    Dim i As Integer
    
    C = Sheets.Count
    ReDim A(2 To C)
    
    For i = 2 To C
        A(i) = Val(Sheets(i).Name)
    Next
    
    Bsort_LtoU A
    
    For i = 2 To C
        Sheets(CStr(A(i))).Move after:=Sheets(C)
    Next
    
End Sub

Private Sub Bsort_LtoU(Ary As Variant)
    'バブルソート
    '引数の値そのものを昇順に並べ替える、1次元配列のみ可
    Dim L As Long
    Dim U As Long
    Dim i As Long
    Dim j As Long
    Dim Temp As Variant
    Dim F As Boolean
    
    L = LBound(Ary)
    U = UBound(Ary)

    '並べ替え
    For i = U To L + 1 Step -1
        F = False
        For j = L To i - 1
            If Ary(j) > Ary(j + 1) Then
                Temp = Ary(j)
                Ary(j) = Ary(j + 1)
                Ary(j + 1) = Temp
                F = True
            End If
        Next
        '交換が発生しなかったら(つまり並べ替わっていたら終わり)
        If F = False Then Exit For
    Next
    
End Sub
top

グラフのイベント処理 ― 任意の埋め込みグラフの要素をダブルクリックするとその情報が表示される例
 グラフ イベント クラス ChartClass ※Settで動作準備ON、ResettでOFF
===== cChartクラス =====
Option Explicit

Private WithEvents myChart As Chart

Public Property Set Chart(Target As Chart)
    Set myChart = Target
End Property
Public Property Get Chart() As Chart
    Set Chart = myChart
End Property

Private Sub Class_Terminate()
    Set myChart = Nothing
End Sub

Private Sub myChart_BeforeDoubleClick(ByVal ElementID As Long, ByVal Arg1 As Long, ByVal Arg2 As Long, Cancel As Boolean)
    If ElementID = xlSeries Then
        myExec myChart, Arg1, Arg2
    End If
    Cancel = True
End Sub

===== 標準モジュール =====
Option Explicit

Private myCharts() As cChart

Sub Sett()
    Dim myChartOBJ As ChartObject
    Dim C As Integer
    Dim i As Integer
    
    C = ActiveSheet.ChartObjects.Count
    ReDim myCharts(1 To C)
    For i = 1 To C
        Set myCharts(i) = New cChart
        Set myCharts(i).Chart = ActiveSheet.ChartObjects(i).Chart
    Next
    
End Sub

Sub Resett()
    Dim i As Integer
    On Error Resume Next
    For i = LBound(myCharts) To UBound(myCharts)
        Set myCharts(i) = Nothing
    Next
    Erase myCharts
    On Error GoTo 0
End Sub

Sub myExec(Target As Chart, SeriesIndex As Long, PointIndex As Long)
    Dim myValues As Variant
    
    With Target
        MsgBox "グラフ名=" & .Name
        MsgBox "グラフオブジェクト名=" & .Parent.Name
        MsgBox "系列番号=" & SeriesIndex
        MsgBox "ポイント番号=" & PointIndex
        MsgBox "系列数式=" & .SeriesCollection(SeriesIndex).Formula
        If PointIndex <> -1 Then
            myValues = .SeriesCollection(SeriesIndex).XValues
            MsgBox "X=" & myValues(PointIndex)
            myValues = .SeriesCollection(SeriesIndex).Values
            MsgBox "Y=" & myValues(PointIndex)
        End If
    End With
End Sub
top

図形消去 ― 図形の一部が、セル選択範囲に含まれていたら消す
 範囲内図形削除 選択範囲内の図形削除
Sub EraseShapes()
    Dim myShp As Shape
    Dim myRange As Range
    Dim ShpRange As Range
    Dim mySht As Worksheet
    
    Set mySht = ActiveSheet
    Set myRange = ActiveWindow.RangeSelection
    
    For Each myShp In mySht.Shapes
        With myShp
            Set ShpRange = mySht.Range(.TopLeftCell, .BottomRightCell)
            If Not Application.Intersect(ShpRange, myRange) Is Nothing Then
                .Delete
            End If
        End With
    Next
    
End Sub
top

フォームのチェックボックス ― シート上のフォームチェックボックスの操作例
 シート フォームツールバー チェックボックス Shape Type リンクセル
Sub test()
    Dim mySht As Excel.Worksheet
    Dim myShp As Excel.Shape
    
    Set mySht = ActiveSheet
    
    For Each myShp In mySht.Shapes
        If myShp.Type = msoFormControl Then
            If myShp.FormControlType = xlCheckBox Then
                With myShp.ControlFormat
                    'プロパティを書き出す
                    Debug.Print myShp.Name
                    Debug.Print .LinkedCell
                    Debug.Print .Value
                    Debug.Print mySht.Range(.LinkedCell).Value
                End With
            End If
        End If
    Next
    
End Sub

Sub Sett()
    'リンクセルをチェックボックスの右のセルに設定する
    Dim mySht As Excel.Worksheet
    Dim myShp As Excel.Shape
    Dim N As Integer
    
    Set mySht = ActiveSheet
    
    For Each myShp In mySht.Shapes
        If myShp.Type = msoFormControl Then
            If myShp.FormControlType = xlCheckBox Then
                N = N + 1
                myShp.TextFrame.Characters.Text = "チェック " & N
                With myShp.ControlFormat
                    .LinkedCell = myShp.TopLeftCell.Offset(0, 1).Address
                End With
            End If
        End If
    Next
End Sub
top

ウィンドウを並べて表示 ― 選択したウィンドウと次のウィンドウを並べて表示する
 ウィンドウ 並べて表示 ※準備:A.xls〜E.xlsまで5個のブックを開いておく
===== ThisWorkbook =====
Option Explicit

Private WithEvents myExcel As Application

Private Sub Workbook_Open()
    Set myExcel = Application
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set myExcel = Nothing
End Sub

Private Sub myExcel_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
    ウインドを並べて表示 Wn.Caption
End Sub

Private Sub ウインドを並べて表示(A As String)
    Dim myWindows(1 To 5) As String
    Dim W As Window
    Dim B As String
    Dim i As Integer
    
    myWindows(1) = "A.xls"
    myWindows(2) = "B.xls"
    myWindows(3) = "C.xls"
    myWindows(4) = "D.xls"
    myWindows(5) = "E.xls"
    
    '次のウインド名を求める
    For i = 1 To UBound(myWindows)
        If myWindows(i) = A Then
            If i = UBound(myWindows) Then
                B = myWindows(1)
            Else
                B = myWindows(i + 1)
            End If
            Exit For
        End If
    Next
    
    If i > UBound(myWindows) Then Exit Sub
    
    With myExcel
        .EnableEvents = False
        .ScreenUpdating = False
    
        '全ウインド最小化
        For Each W In .Windows
            If W.Visible Then
                W.WindowState = xlMinimized
            End If
        Next
        
        '二つのウインドを元の大きさに戻す
        .Windows(B).WindowState = xlNormal
        .Windows(A).WindowState = xlNormal
        
        '並べて表示
        .Windows.Arrange ArrangeStyle:=xlVertical
        
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
top

追加シートのみでイベント ― 常に追加した最後のシート上でのみイベント動作する
 シート イベント NewSheet
===== ThisWorkbook =====
Option Explicit

Private WithEvents mySheet As Worksheet

Private Sub Workbook_Open()
    Worksheets.Add
End Sub

Private Sub Workbook_NewSheet(ByVal Sh As Object)
    Set mySheet = Sh
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set mySheet = Nothing
End Sub

Private Sub mySheet_Change(ByVal Target As Range)
    MsgBox Target.Address
End Sub
top

右クリックして偶数行なら1 ― Sheet1, A列の偶数行で右クリックしたら、「1」と色塗りのON, OFF
 右クリック 偶数行 「1」のON,OFF 色塗り切り替え
===== ThisWorkbook =====
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If Sh.Name <> "Sheet1" Then Exit Sub                'Sheet1でなければ
    If Target.Columns.Count >= 2 Then Exit Sub          '2列以上なら
    If Target.Column <> 1 Then Exit Sub                 'A列でなければ
    If Target.Rows.Count = Sh.Rows.Count Then Exit Sub  '列選択されたら
    Cancel = True
    
    Dim myCell As Range
    For Each myCell In Target
        With myCell
            '偶数行なら
            If .Row Mod 2 = 0 Then
                If .Value = 1 Then
                    .Value = ""
                    .EntireRow.Interior.ColorIndex = xlNone
                Else
                    .Value = 1
                    'ラベンダー
                    .EntireRow.Interior.Color = RGB(191, 127, 255)
                End If
            End If
        End With
    Next
    
End Sub
top

テキストファイル範囲抜粋 ― テキストファイル中で、#1#の次の行から#2#の前までを抽出する
 テキストファイル 範囲抽出
===== a.txt =====	
aaaaa	
bb	
ccc	
#1#	
dddddd	←ここから
e	
ff	←ここまでを抽出
#2#	
gggg	
hh	

Sub Test()
    Dim Fname As String
    Dim N As Integer
    Dim myData As String
    Dim Mikke As Boolean
    
    Fname = ThisWorkbook.Path & "\a.txt"
    N = FreeFile(0)
    
    Open Fname For Input As #N
    
    Mikke = False
    Do While Not EOF(N)
        Line Input #N, myData
        If myData = "#1#" Then
            Mikke = True
            Exit Do
        End If
    Loop
    
    If Mikke = False Then
        Close #N
        Exit Sub
    End If
    
    Do While Not EOF(N)
        Line Input #N, myData
        If myData = "#2#" Then
            Exit Do
        Else
            Debug.Print myData
        End If
    Loop
    
    Close #N
End Sub
top

ポイントラベル付き散布図グラフ ― 散布図の各ポイントに任意のラベルを表示する、一系列限定
 散布図 グラフ ポイントラベル 任意のラベル Point
SampleData
Label	xx	yy
a	1	2
b	2	5
c	3	3
d	4	6
e	5	1

'ラベル、X、Yの順で並んだデータで散布図を描き各ポイントにラベルの値を表示する
Sub CreateChart()
    Dim rngSource As Range
    Dim myChartOBJ As ChartObject
    Dim mySeries As Series
    Dim myPoint As Point
    Dim i As Integer
    Dim Txt As String
    
    '元データ範囲
    Set rngSource = Range("A1:C6")
    '元データ範囲の右にグラフ作成
    With rngSource.Offset(, rngSource.Columns.Count)
        Set myChartOBJ = ActiveSheet.ChartObjects.Add(.Left, .Top, 400, 300)
    End With
    
    With myChartOBJ.Chart
        .ChartArea.AutoScaleFont = False
        .ChartType = xlXYScatter
        .SetSourceData rngSource.Offset(, 1).Resize(, 2), xlColumns
        .ApplyDataLabels xlDataLabelsShowValue
        .HasLegend = False
        .ChartTitle.Text = "タイトル"
        
        Set mySeries = .SeriesCollection(1)
        i = 1
        For Each myPoint In mySeries.Points
            i = i + 1
            '各ポイントのラベルに「値」を表示
            Txt = rngSource.Cells(i, 1).Address(0, 0, xlR1C1, 0)
            Txt = "=" & rngSource.Worksheet.Name & "!" & Txt
            myPoint.DataLabel.Text = Txt
        Next
    End With
    
    Set myPoint = Nothing
    Set mySeries = Nothing
    Set myChartOBJ = Nothing
    Set rngSource = Nothing
End Sub
top

グラフに任意の値のラベルを表示 ― 元データの右にラベルに表示する値を置き、それを表示する
 グラフに任意ラベル表示 グラフに任意のラベルを表示 シリーズ ポイント
SampleData
xxx	y1	y2	L1	L2
a	1	2	あ	xx
b	3	3	い	yy
c	5	4	う	zz

Sub CreateChart()
    Dim rngSource As Range
    Dim myChartOBJ As ChartObject
    Dim mySeries As Series
    Dim myRange As Range
    Dim SeriesCount As Integer
    Dim myPoint As Point
    Dim i As Integer
    
    '元データ範囲
    Set rngSource = Range("A1:C4")
    '元データ範囲の右にグラフ作成
    With rngSource.Offset(, rngSource.Columns.Count)
        Set myChartOBJ = rngSource.Worksheet.ChartObjects.Add(.Left, .Top, 500, 300)
    End With
    
    With myChartOBJ.Chart
        .ChartArea.AutoScaleFont = False
        .ChartType = xlLineMarkers
        .SetSourceData rngSource, xlColumns
        .ApplyDataLabels xlDataLabelsShowValue
        '表示するラベルのOffset
        SeriesCount = .SeriesCollection.Count
        
        For Each mySeries In .SeriesCollection
            'ラベルの「値」のあるセル範囲
            Set myRange = Range(Split(mySeries.Formula, ",")(2))
            Set myRange = myRange.Offset(, SeriesCount)
            
            i = 0
            For Each myPoint In mySeries.Points
                i = i + 1
                '各ポイントのラベルに「値」を表示
                myPoint.DataLabel.Text = myRange.Cells(i).Text
            Next
        Next
    End With
    
    Set myPoint = Nothing
    Set myRange = Nothing
    Set mySeries = Nothing
    Set myChartOBJ = Nothing
    Set rngSource = Nothing
End Sub
top

グラフのデータラベル表示 ― 条件にあったポイントごとに個別にデータラベルを表示する
 データラベルの条件付表示 ポイント毎のラベル表示 個別ポイントのラベル ※この例では値が10を超えるポイントにのみラベルを表示している
Sub データラベル表示()
    Dim myChart As Chart
    Dim mySeries As Series
    Dim myPoint As Point
    Dim i As Integer
    Dim myVals As Variant
    Const 基準値 As Integer = 10
    
    Application.ScreenUpdating = False
    
    Set myChart = ActiveChart
    myChart.ApplyDataLabels xlDataLabelsShowNone
    
    For Each mySeries In myChart.SeriesCollection
        myVals = mySeries.Values
        For i = 1 To UBound(myVals)
            If myVals(i) > 基準値 Then
                Set myPoint = mySeries.Points(i)
                myPoint.ApplyDataLabels xlDataLabelsShowValue
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
End Sub
top

グラフ中の任意の位置にテキストボックスを描く ― 指定した値を、縦のスケールに沿った適切な位置にテキストボックスで描く例
 グラフの任意位置に文字 グラフ目盛りで位置指定 インサイドトップ インサイドレフト ※この例では縦目盛り15、縦軸内側の位置に「15」とテキストボックスで描く
Sub Test()
    Const Y As Single = 15
    Dim myTop As Single
    Dim myleft As Single
    Dim myTxt As Shape
    
    With ActiveChart.Axes(xlValue)
        myTop = (Y - .MaximumScale) / (.MinimumScale - .MaximumScale)
    End With
    With ActiveChart.PlotArea
        myTop = myTop * .InsideHeight + .InsideTop
        myleft = .InsideLeft
    End With
    
    Set myTxt = ActiveChart.Shapes.AddTextbox _
        (msoTextOrientationHorizontal, _
        myleft, myTop, 10, 10)
    With myTxt
        .TextFrame.Characters.Text = CStr(Y)
        .TextFrame.AutoSize = True
        .Left = myleft
        .Top = myTop - .Height
    End With
    
End Sub
top

フォーム位置保持 ― ユーザーフォームの表示位置をテキストファイルで保持する
 ユーザーフォーム表示位置 表示位置の保持 ※ユーザーフォームのプロパティでStartUpPosition=Manualに設定しておく
===== UserForm1 =====
Option Explicit

Private PosFpath As String

Private Sub cmdOK_Click()
    Dim N As Integer
    N = FreeFile
    Open PosFpath For Output As #N
    With Me
        Print #N, .Left
        Print #N, .Top
    End With
    Close #N
    
    MsgBox "OK"
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Dim N As Integer
    Dim D As Single
    
    PosFpath = ThisWorkbook.Path & "\" & "FormPosition.txt"
    If Dir(PosFpath) = "" Then Exit Sub
    
    N = FreeFile
    Open PosFpath For Input As #N
    With Me
        Input #N, D: .Left = D
        Input #N, D: .Top = D
    End With
    Close #N
End Sub
top

2つのフォームで循環 ― frmA, frmBを交互に表示するサンプル
 ユーザーフォーム 交互表示 相互呼出 フォーム使用例 ※必要パーツ(frmA/frmB共):cmd表示切替, cmdキャンセル
===== frmA(frmB) =====
Option Explicit

Public ClickedButton As Integer

Private Sub cmd表示切替_Click()
    ClickedButton = vbOK
    Me.Hide
End Sub

Private Sub cmdキャンセル_Click()
    ClickedButton = vbCancel
    Me.Hide
End Sub

Private Sub UserForm_Initialize()
    ClickedButton = vbCancel
End Sub

===== 標準モジュール =====
Sub test()
    Do
        frmA.Show
        If frmA.ClickedButton = vbCancel Then
            Unload frmA
            Exit Do
        End If
        Unload frmA
        
        frmB.Show
        If frmB.ClickedButton = vbCancel Then
            Unload frmB
            Exit Do
        End If
        Unload frmB
    Loop
End Sub
top

表の変換 ― 縦氏名、横日付&曜日の表に「○」があり、「○」部分のみを日付毎にまとめ、何日は誰と誰がわかるような表にする
 表 変換 日付毎
	7月1日	7月2日	7月3日	7月4日	7月5日	7月6日
氏名	木	金	土	日	月	火
A	○			○		○
B		○			○	
C			○		○	
D				○		○
E		○		○		○
F	○		○			
 ↓
月日	氏名
04/7/1	A
	F
04/7/2	B
	E
04/7/3	C
	F
04/7/4	A
	D
	E
04/7/5	B
	C
04/7/6	A
	D
	E

Sub 夜勤()
    Dim myTable As Range
    Dim myColumn As Range
    Dim myDest As Range
    Dim i As Integer
    
    '処理対象範囲
    Set myTable = ActiveSheet.UsedRange
    '中の○の部分に絞る
    With myTable
        Set myTable = Intersect(.Offset(2, 1), .Cells)
    End With

    '書込み先
    Set myDest = Worksheets.Add.Range("A1")
    
    '項目名
    myDest.Value = "月日"
    myDest.Offset(0, 1).Value = "氏名"
    Set myDest = myDest.Offset(1, 0)
    
    '列(月日)のループ
    For Each myColumn In myTable.Columns
        '日付書込み
        myDest.Value = myColumn.Cells(1).Offset(-2).Value
        '書込み先を一列右へ
        Set myDest = myDest.Offset(, 1)
        
        '行(氏名)のループ
        For i = 1 To myColumn.Cells.Count
            With myColumn.Cells(i)
                '○なら書込み
                If .Value = "○" Then
                    '氏名書き込み
                    myDest.Value = myTable.Cells(i, 1).Offset(, -1).Value
                    '書込み先を一行下へ
                    Set myDest = myDest.Offset(1)
                End If
            End With
        Next
        
        '書込み先を一列左へ(日付の列)
        Set myDest = myDest.Offset(, -1)
    Next
    
    Set myTable = Nothing
    Set myColumn = Nothing
    Set myDest = Nothing
End Sub
top

CSV更新で自動実行 ― あるファイルを監視し、更新されたら処理を実行する
 ファイル更新で自動実行 ファイル監視 更新日 OnTime FileDateTime ※ソート関数forExcelVBA(MsToolsC.xla)への参照設定要
Public Sub 更新日確認()
    Dim myIni As cMsIni
    Dim iniPath As String
    Dim iniSection As String
    Dim iniKey As String
    Dim 最終更新日 As String
    Dim 現在の更新日 As String
    
    'iniファイルで「最終更新日」を読み書きする準備
    iniPath = ThisWorkbook.Path & "\myProject.ini"
    iniSection = "[最終更新日]"
    iniKey = "あるCSV="
    Set myIni = GetMsIni
    
    '最終更新日を取得
    With myIni
        .FilePath = iniPath
        .Section = iniSection
        最終更新日 = .GetData(iniKey)
    End With
    
    '現在のファイルの更新日を取得
    現在の更新日 = FileDateTime(ThisWorkbook.Path & "\ある.csv")
    
    '新しければ処理
    If 現在の更新日 > 最終更新日 Then
        MsgBox "処理"
        'iniファイル上の最終更新日を書き換え
        myIni.PutData iniKey, 現在の更新日
    End If
    
    '後始末
    Set myIni = Nothing
    
    '指定時間後に繰り返す
    Application.OnTime Now() + TimeValue("00:00:10"), "更新日確認"
    
End Sub
top

色で並べ替え ― セルの色で並べ替える
 色で並べ替え 色で並替え 色で並び替え 配列の並べ替え ※ソート関数forExcelVBA(MsToolsC.xla)に参照設定要
Sub 色で並べ替え()
    Dim mySort As MsToolsC.cMsQsort
    Dim myRange As Range
    Dim myRow As Range
    Dim myLists() As Long
    Dim myIndex As Variant
    Dim i As Long
    Dim tmpBook As Workbook
    Dim tmpSheet As Worksheet
    Dim tmpCell As Range
    Const 対象列 As Integer = 1
    
    '並べ替え準備
    Set mySort = MsToolsC.GetMsQsort
    
    '処理対象範囲
    Set myRange = ActiveSheet.UsedRange
    ReDim myLists(1 To myRange.Rows.Count)
    
    '色の値を配列に読み込む
    For i = 1 To myRange.Rows.Count
        myLists(i) = myRange.Cells(i, 対象列).Interior.ColorIndex
    Next
    
    '配列を並べ替え、そのインデックスを得る
    With mySort
        .昇順 = True
        .同値順位保持 = True
        myIndex = .MsQsort(myLists)
    End With
    
    Application.ScreenUpdating = False
    
    '作業用のブック準備
    Set tmpBook = Workbooks.Add
    Set tmpSheet = tmpBook.Worksheets(1)
    Set tmpCell = tmpSheet.Range("A1")
    
    'インデックス順に作業用のシートにコピー
    For i = 1 To UBound(myIndex)
        myRange.Rows(myIndex(i)).Copy tmpCell
        Set tmpCell = tmpCell.Offset(1, 0)
    Next
    
    '作業用シートから書き戻し
    tmpSheet.UsedRange.Copy myRange
    
    Set tmpCell = Nothing
    Set tmpSheet = Nothing
    tmpBook.Close False
    Set tmpBook = Nothing

    Application.ScreenUpdating = True
End Sub
top

全ブックに対するイベント処理 ― 自ブック以外も含めたすべてのブックのイベント処理
 他ブックのイベント処理 他のブックのイベント アプリケーションレベルのイベント
===== ThisWorkbook =====
Option Explicit

Private WithEvents myExcel As Application

Private Sub Workbook_Open()
    Set myExcel = Application
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set myExcel = Nothing
End Sub

Private Sub myExcel_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)
    MsgBox Target.Address(1, 1, xlA1, 1)
    Cancel = True
End Sub
top

選択セルの行と列の色変更 ― アクティブセルがどこなのかを分かりやすくするために選択したセルの行と列に色を塗る
 カーソル 選択行 選択列 色塗り 識別 ※元々シートに色が塗ってあると消えてしまう
===== ThisWorkbook =====
Option Explicit

Private rngBak As Range

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    If rngBak Is Nothing Then
    Else
        rngBak.Interior.ColorIndex = xlNone
    End If
    
    Set rngBak = Union(Target.EntireRow, Target.EntireColumn)
    rngBak.Interior.Color = vbYellow

End Sub
top

OnTimeサンプル2 ― A1セルに0−9を繰り返し表示、60秒経ったら終了
Option Explicit

Private myNumber As Integer
Private myStart As Single
Private NextTime As Date

Sub Start()
    myStart = Timer
    Hyouji
End Sub

Sub Hyouji()
    If Timer - myStart < 60 Then
        Range("A1").Value = myNumber
        myNumber = (myNumber + 1) Mod 10
        
        NextTime = Now + TimeValue("00:00:01")
        Application.OnTime NextTime, "Hyouji"
    End If
    
End Sub

Sub myEnd()
    Application.OnTime NextTime, "Hyouji", , False
End Sub
top

OnTimeサンプル ― OnTimeで10秒毎に繰り返すサンプル
Option Explicit

Private myTime As Date

Sub Startt()
    myTime = Now() + TimeValue("00:00:10")
    Application.OnTime myTime, "Startt"
    '処理
    MsgBox "次回:" & myTime
End Sub

Sub Stopp()
    Application.OnTime myTime, "Startt", , False
End Sub
top

スピンでデータ表示 ― ユーザーフォーム上のスピンボタンで、シートのデータをテキストボックスにスクロール表示
 スピンボタンでスクロール 同期表示 ※動作に必要なパーツ:UserForm1, SpinButton1, txt行番号, txtあ, txtい, 6列以上のデータ
Option Explicit

Private rngTable As Range
Private DontMove As Boolean

Private Sub SpinButton1_Change()
    If DontMove Then Exit Sub
    Me.txt行番号 = Me.SpinButton1.Value
End Sub

Private Sub txt行番号_Change()
    Dim R As String
    R = Me.txt行番号
    If R = "" Then
        Me.txtあ.Value = ""
        Me.txtい.Value = ""
    Else
        With Me.SpinButton1
            If Val(R) >= .Min And Val(R) <= .Max Then
                With rngTable.Item(Val(R))
                    '最左列の値
                    Me.txtあ.Value = .Offset(, 0).Value
                    '5列右の値
                    Me.txtい.Value = .Offset(, 5).Value
                End With
                DontMove = True
                .Value = Val(R)
                DontMove = False
            End If
        End With
    End If
End Sub

Private Sub UserForm_Initialize()
    'データ範囲(最左列)
    Set rngTable = Worksheets("Sheet1").Range("A1")
    Set rngTable = Range(rngTable, rngTable.End(xlDown))
    
    With Me.SpinButton1
        .Min = 1
        .Max = rngTable.Rows.Count
        .SmallChange = -1
        .Orientation = fmOrientationVertical
    End With
End Sub
top

右クリックメニューサンプル2 ― シートモジュールに設定し、そのシートでのみ動作するメニューを追加する例
 シート毎のメニュー 単一シートのみで動作するメニュー
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
    Const myMenu As String = "myMenu"
    Dim Pop As CommandBarPopup
    Cancel = True
    With Application.CommandBars("Cell")
        .Controls(1).BeginGroup = True
        Set Pop = .Controls.Add(Type:=msoControlPopup, before:=1, temporary:=True)
        With Pop
            .Caption = myMenu
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Menu_1"
                .OnAction = "Menu_1"   '実行するプロシージャは標準モジュールに書く
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Menu_2"
                .OnAction = "Menu_2"   '実行するプロシージャは標準モジュールに書く
            End With
        End With
        .ShowPopup
        .Controls(myMenu).Delete
    End With
End Sub
top

右クリックメニューサンプル ― メニュー自体に引数を設定しておき、同一プロシージャで異なる処理をする例
 メニューに引数 メニューにパラメータ 同一マクロで別処理実行
===== ThisWorkbook =====
Option Explicit

Private Sub Workbook_Open()
    Dim newMenu As CommandBarButton
    Dim i As Integer
    
    For i = 5 To 1 Step -1
        Set newMenu = Application.CommandBars("Cell") _
            .Controls.Add(Type:=msoControlButton, _
            before:=1, temporary:=True)
        With newMenu
            .Caption = "C" & i & "の値で埋める"
            .OnAction = "Kakikomi"
            .Parameter = i
        End With
    Next i
End Sub

===== 標準モジュール =====
Private Sub Kakikomi()
    Dim CalledButton As CommandBarButton
    Dim n As Integer
    
    Set CalledButton = Application.CommandBars.ActionControl
    n = CInt(CalledButton.Parameter)
    'Cnの値で埋め尽くす
    Selection.Value = Range("C" + CStr(n)).Value

End Sub
top

VBSサンプル ― VBスクリプトでExcelのプロシージャを実行する
 VBScript Excel非表示 マクロ警告 ※メモ帳などに貼付け、test.vbsなどと名前を付けて保存する
Dim xlApp
Dim xlBook

' Excelのインスタンス作成
Set xlApp = CreateObject("Excel.Application")

' Excelの表示有無
xlApp.Visible = False

' メッセージを表示しないように設定(これが無くてもマクロの警告は出ない)
xlApp.DisplayAlerts = False

' 指定したExcelブックを開く
Set xlBook = xlApp.Workbooks.Open("C:\Temp\Test.xls")

' Excelの標準モジュールのTestをCall
xlApp.Run "TEST"

'ブックを保存せずに閉じる
xlBook.Close False

' Excel終了
xlApp.Quit

' オブジェクトを解放
Set xlBook = Nothing
Set xlApp = Nothing
top

同じ行数ずつデータを転記 ― 実行する毎に、元シートから同じ行数分のデータを作業用のシートに取り込む(作業用シートは都度データクリアする)
 同一行数ずつ 同数ずつ 同じ場所へコピー 同一シートへコピー 同一セルへコピー
Sub 同じ行数ずつデータを転記()
    Dim rngSource As Range
    Dim myRows As Range
    Dim rngDest As Range
    Static myCell As Range
    
    '転記の単位
    Const myRowsCount As Integer = 6
    
    'コピー元と転記先
    Set rngSource = Worksheets("Sheet1").UsedRange
    Set rngDest = Worksheets("Sheet2").Cells(1)
    
    '基準セル(スタートはSheet1のActiveCellから)
    If myCell Is Nothing Then
        Worksheets("Sheet1").Activate
        Set myCell = ActiveCell
        Worksheets("Sheet2").Activate
    End If
    
    '基準セルから下n行を取得
    Set myRows = myCell.EntireRow
    Set myRows = Application.Intersect(myRows, rngSource)
    If myRows Is Nothing Then
        MsgBox "End!"
        Exit Sub
    End If
    Set myRows = myRows.Resize(myRowsCount)
    
    '転記先のシートの値をクリアしてから値のみを貼り付ける
    rngDest.Worksheet.Cells.ClearContents
    myRows.Copy
    rngDest.PasteSpecial xlPasteValues
    
    '基準セルをn行下に移動する
    Set myCell = myRows.Cells(myRows.Rows.Count, 1)
    Set myCell = myCell.Offset(1, 0)
    
    Set rngSource = Nothing
    Set myRows = Nothing
    Set rngDest = Nothing
End Sub
top

ブック結合 ― 複数のブックのワークシート各1枚を新しいひとつのブックの1つのワークシートにまとめる
 フォルダ内ファイル フォルダ内ブック 連続処理 結合 統合 複数のブック 複数のファイル
Sub 結合()
    Dim SourceBook As Workbook
    Dim rngSource As Range
    Dim rngDest As Range
    Dim myPath As String
    Dim myFName As String
    
    '処理対象のフォルダ指定
    myPath = ThisWorkbook.Path & "\"
    
    '新規ブックを作成し、そのSheet1のA1セルを書き込み先とする
    Set rngDest = Application.Workbooks.Add.Worksheets(1).Cells(1, 1)
    
    Application.ScreenUpdating = False
    
    myFName = Dir(myPath & "*.xls")
    
    Do Until myFName = ""
        If myFName <> ThisWorkbook.Name Then
            Set SourceBook = Application.Workbooks.Open(myPath & myFName)
            Set rngSource = SourceBook.Worksheets(1).UsedRange
            rngSource.Copy rngDest
            Set rngDest = rngDest.Offset(rngSource.Rows.Count)
            SourceBook.Close False
        End If
        myFName = Dir()
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox "ブックの結合が完了しました。", vbInformation
    
    Set rngSource = Nothing
    Set rngDest = Nothing
    Set SourceBook = Nothing
End Sub
top

CSV出力 ― アクティブシートの使用範囲のデータ(各行毎に列数不定、データの在る範囲内)をCSVファイルに出力する("は付けない)
 CSV 行数不定 列数不定 "無し
Sub myCSV()
    Dim myColumn As Range
    Dim myCell As Range
    Dim myLastCell As Range
    Dim myRow As Range
    Dim Fname As String
    Dim N As Integer
    Dim i As Integer
    
    Set myColumn = ActiveSheet.UsedRange
    Set myColumn = myColumn.Columns(1)
    
    Fname = ThisWorkbook.Path & "\Test.csv"
    N = FreeFile(0)
    Open Fname For Output As #N
    
    For Each myCell In myColumn.Cells
        With myCell
            Set myLastCell = .EntireRow
            Set myLastCell = myLastCell.Cells(myLastCell.Cells.Count)
            Set myLastCell = myLastCell.End(xlToLeft)
            If myLastCell.Column < myCell.Column Then
                Set myRow = myCell
            Else
                Set myRow = .Worksheet.Range(myCell, myLastCell)
            End If
        End With
        
        With myRow
            Print #N, .Cells(1).Value;
            For i = 2 To .Cells.Count
                Print #N, ","; .Cells(i).Value;
            Next
            Print #N, ""
        End With
    Next
    
    Close #N
    
    Set myColumn = Nothing
    Set myCell = Nothing
    Set myLastCell = Nothing
    Set myRow = Nothing
End Sub
top

「〃」の付いた並べ替え ― 「〃」(同上)を一旦上と同じ値にして並べ替え、後で「〃」に戻す
 〃 々 同上 並替え 並び替え
Sub Sortt()
    Dim myRange As Range
    Dim myColumn As Range
    Dim myCell As Range
    Dim i As Long
    
    Set myRange = ActiveCell.CurrentRegion
    Set myColumn = myRange.Columns(1)
    
    '「〃」を上の値と同じにする
    For Each myCell In myColumn.Cells
        With myCell
            If .Value = "〃" Then
                .Value = .Offset(-1).Value
            End If
        End With
    Next
    
    '並べ替え
    myRange.Sort key1:=myColumn.Cells(1), Header:=xlYes
    
    '元に戻す
    For i = myColumn.Rows.Count To 2 Step -1
        Set myCell = myColumn.Cells(i)
        With myCell
            If .Value = .Offset(-1).Value Then
                .Value = "〃"
            End If
        End With
    Next
    
    Set myRange = Nothing
    Set myColumn = Nothing
    Set myCell = Nothing
    
End Sub
top

一行おきに行を挿入 ― 2列目の値を1列目の下に行を挿入して差し込む
 行挿入 2列を1列に 二列を一列に 行差込み
1	a		1
2	b		a
3	c	⇒	2
			b
			3
			c
Sub Sample1()
    Dim myRange As Range
    Dim myRow As Range
    Dim i As Integer
    
    Set myRange = ActiveCell.CurrentRegion
    For i = myRange.Rows.Count To 2 Step -1
        Set myRow = myRange.Rows(i)
        myRow.Insert shift:=xlDown
    Next
    
    Set myRange = myRange.Columns(2)
    myRange.Copy
    myRange.Offset(1, -1).PasteSpecial skipblanks:=True
    
    myRange.Clear
    
    Set myRange = Nothing
    Set myRow = Nothing
    
End Sub
top

Rangeの一行目をカット
 項目名カット 行見出しカット データだけ取得
Sub test()
    Dim myList As Range
    Set myList = Selection
    Set myList = Intersect(myList, myList.Offset(1))
    myList.Select
End Sub
top

Excel97用簡易版Split関数
 スプリット 文字列分割 文字列分解 文字区切り
Sub Split97CallSample()
    Const S As String = "aaa,b,cc,dddd"
    Dim V As Variant
    Dim i As Integer

    V = Split97(S, ",")

    For i = 0 To UBound(V)
        Debug.Print V(i)
    Next
End Sub

Public Function Split97(Exp As String, Deli As String) As Variant
    '配列添え字の下限は0
    Dim myArray() As String
    Dim C As Integer
    Dim i As Integer
    Dim j As Integer
    
    i = 1
    Do
        j = InStr(i, Exp, Deli)
        If j = 0 Then
            j = Len(Exp) + 1
        End If
            
        ReDim Preserve myArray(0 To C)
        myArray(C) = Mid$(Exp, i, j - i)
        
        i = j + Len(Deli)
        C = C + 1
        
    Loop While j <= Len(Exp)
    
    Split97 = myArray
End Function
top

右クリックでシート選択3 ― 右クリックメニューにコンボボックスを追加し、複数ブックの中からシートを選択
 ブックリスト シートリスト コマンドバーコンボボックス 注:プロジェクト名をmyPrjとすること
===== ThisWorkbook モジュール =====
Option Explicit

Private WithEvents myExcel As Application

'このブックのプロジェクト名と同じ値を設定すること
Private Const myProjectName As String = "myPrj"

Private Const BarCaption As String = "シート選択"

'機能を有効にするにはブックを開き直すかここを実行する
Private Sub Workbook_Open()
    Set myExcel = Application
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set myExcel = Nothing
End Sub

Private Sub myExcel_SheetBeforeRightClick _
    (ByVal Sh As Object, ByVal Target As Range _
    , Cancel As Boolean)

    Dim myBar As CommandBarComboBox
    Dim myBarName As String
    Dim Wb As Workbook
    Dim Ws As Worksheet
    
    With Target
        If .Columns.Count = Sh.Columns.Count Then
            If .Rows.Count = Sh.Rows.Count Then
                myBarName = "Cell"
            Else
                myBarName = "Row"
            End If
        ElseIf .Rows.Count = Sh.Rows.Count Then
            myBarName = "Column"
        Else
            myBarName = "Cell"
        End If
    End With
    
    Application.CommandBars(myBarName).Controls(1).BeginGroup = True
    Set myBar = Application.CommandBars(myBarName).Controls.Add _
        (Type:=msoControlComboBox, before:=1, temporary:=True)
    
    With myBar
        .Caption = BarCaption
        .OnAction = myProjectName & ".ThisWorkbook.シート選択"
        For Each Wb In Workbooks
            For Each Ws In Wb.Worksheets
                .AddItem Wb.Name & "!" & Ws.Name
            Next
        Next
    End With
    
    Application.CommandBars(myBarName).ShowPopup
    myBar.Delete
    
    Cancel = True
    Set myBar = Nothing
    
End Sub

Private Sub シート選択()
    Dim A As Variant
    A = Split(Application.CommandBars.ActionControl.Text, "!")
    Workbooks(A(0)).Worksheets(A(1)).Activate
End Sub
top

右クリックでシート選択2 ― 右クリックメニューに追加することにより、本来の右クリックも使えるようにした
 ワークシート選択 シートリスト表示 注:プロジェクト名をmyPrjとすること
===== ThisWorkbook =====
Option Explicit

Private WithEvents myExcel As Application

'機能を有効にするにはブックを開き直すかここを実行する
Private Sub Workbook_Open()
    Set myExcel = Application
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set myExcel = Nothing
End Sub

Private Sub myExcel_SheetBeforeRightClick _
    (ByVal Sh As Object, ByVal Target As Range _
    , Cancel As Boolean)

    Dim myBar As CommandBarPopup
    Dim myBarName As String
    
    With Target
        If .Columns.Count = Sh.Columns.Count Then
            If .Rows.Count = Sh.Rows.Count Then
                myBarName = "Cell"
            Else
                myBarName = "Row"
            End If
        ElseIf .Rows.Count = Sh.Rows.Count Then
            myBarName = "Column"
        Else
            myBarName = "Cell"
        End If
    End With
    
    Application.CommandBars(myBarName).Controls(1).BeginGroup = True
    Set myBar = Application.CommandBars(myBarName).Controls.Add _
        (Type:=msoControlPopup, before:=1, temporary:=True)
    
    With myBar
        .Caption = "シート選択"
        .OnAction = "myPrj.ThisWorkbook.シート選択表示"
    End With
    
    Application.CommandBars(myBarName).ShowPopup
    myBar.Delete
    
    Cancel = True
    Set myBar = Nothing
    
End Sub

Private Sub シート選択表示()
    Application.CommandBars("Workbook tabs").ShowPopup
End Sub
top

右クリックでシート選択 ― A列の右クリックでシート選択用のリストを表示する
 ワークシート選択 シートリスト表示
===== ThisWorkbook =====
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If Target.Column <> 1 Then Exit Sub
    Application.CommandBars("Workbook tabs").ShowPopup
    Cancel = True
End Sub
top

Wait ― 指定秒間待つ
 Wait Sleep 一時停止 注:夜中の0時をまたぐ場合は使えません
Private Sub Waitt(Optional T As Single = 1)
    'T秒間待つ
    Dim T1 As Single
    T1 = Timer + T
    Do While Timer < T1
        DoEvents
    Loop
End Sub
top

オートフィルタで行抽出 ― 項目名と値を引数で渡し、含むの条件でオートフィルタを実行し新規シートに移動する例
 オートフィルタ AutoFilter AutoFilterMode
Sub test()
    myFilter "BB", "M"
End Sub

Sub myFilter(項目 As String, 値 As String)
    Dim rngDest As Range
    Dim rngTitle As Range
    Dim rngFind As Range
    
    With ActiveCell.Worksheet.UsedRange
        .Worksheet.AutoFilterMode = False
        Set rngTitle = .Rows(1)
        Set rngFind = rngTitle.Find(項目, , xlValues, xlPart)
        If rngFind Is Nothing Then Exit Sub
        
        .AutoFilter rngFind.Column, "=*" & 値 & "*"
        
        Set rngDest = Worksheets.Add.Range("A1")
        rngTitle.Copy rngDest
        Set rngDest = rngDest.Offset(1)
        
        With .Offset(1).SpecialCells(xlCellTypeVisible)
            .Copy rngDest
            .Delete xlUp
        End With
        
        .Worksheet.AutoFilterMode = False
    End With
End Sub
top

ショートカット作成 ― Windows Scripting Host にてデスクトップパスを取得し、そこにこのブックへのショートカットを作る
 ショートカット デスクトップ WSH Scripting Host
Sub ショートカット作成()
    'デスクトップにショートカットを作成する
    '(Windows Script Host Object Modelに参照設定し、専用のオブジェクト型
    'を使用すればインテリセンスが使用できる)
    Dim Fld As String
    Dim Wsh As Object       'IWshShell
    Dim ShtCut As Object    'IWshShortcut_Class
    
    Set Wsh = CreateObject("Wscript.Shell")
    Fld = Wsh.SpecialFolders("Desktop")
    
    Set ShtCut = Wsh.CreateShortcut(Fld & "\test.lnk")
    With ShtCut
        .TargetPath = ThisWorkbook.FullName
        .WindowStyle = 1
        .IconLocation = Application.Path & "\excel.exe, 1"
        .Description = "ショートカット作成テスト"
        .Save
    End With
    
    Set ShtCut = Nothing
    Set Wsh = Nothing
End Sub
top

デスクトップのパス
 デスクトップパス システムフォルダ Wscript
Sub test()
    'デスクトップのパス
    MsgBox CreateObject("WScript.Shell").SpecialFolders("Desktop")
End Sub
top

下付き ― セルに数字が含まれていたらその部分の書式を下付きにする
 セル 書式 下付き 上付き 数字を小文字にする
Sub Call下付き()
    下付き Selection
End Sub

Sub 下付き(Target As Range)
    Dim A As String
    Dim i As Integer
    Dim myCell As Range
    
    For Each myCell In Target.Cells
        With myCell
            For i = 1 To Len(.Value)
                A = Mid$(.Value, i, 1)
                If A Like "[-+0-9]" Then
                    .Characters(i, 1).Font.Subscript = True
                End If
            Next
        End With
    Next
    
End Sub
top

組合せ ― 組合せ nCr の配列を返す(再帰使用)、RetMax=TRueの時は組合せ数を返す
 組み合わせ 組合せ 再帰呼出 nCr
Public Function nCr(n As Integer, r As Integer, Optional RetMax As Boolean = False) As Variant
    '組合せ nCr の配列を返す、RetMax=TRueの時は組合せ数を返す
    If n <= 0 Or r <= 0 Then Exit Function
    If r > n Then Exit Function

    Dim C() As Integer
    Dim Rc As Long
    Dim Max As Double
    Dim i As Integer
    Dim IJK() As Integer
    Dim vntIJK As Variant
    Dim Zan As Integer
    
    Max = 1
    For i = n To (n - r + 1) Step -1
        Max = Max * i
    Next
    For i = r To 1 Step -1
        Max = Max / i
    Next
    
    If RetMax = True Then
        nCr = Max
        Exit Function
    End If
    
    ReDim C(1 To Max, 1 To r)
    Rc = 0

    ReDim IJK(0 To 0)
    Zan = r
    IJK(0) = 0
    vntIJK = IJK()
    SetnCr C(), Rc, n, r, vntIJK, Zan - 1
    
    nCr = C()
    
End Function

Private Sub SetnCr(C() As Integer, Rc As Long, n As Integer, r As Integer, ByVal vntIJK As Variant, ByVal Zan As Integer)
    Dim k As Integer
    Dim l As Integer
    Dim m As Integer
    Dim IJK() As Integer
    
    If Zan = 0 Then
        k = vntIJK(UBound(vntIJK))
        For l = k + 1 To n
            Rc = Rc + 1
            For m = 1 To UBound(vntIJK)
                C(Rc, m) = vntIJK(m)
            Next
            C(Rc, m) = l
        Next
    Else
        ReDim IJK(0 To UBound(vntIJK) + 1)
        For k = 0 To UBound(vntIJK)
            IJK(k) = vntIJK(k)
        Next
        
        k = vntIJK(UBound(vntIJK))
        For l = k + 1 To n - Zan
            IJK(UBound(IJK)) = l
            vntIJK = IJK()
            SetnCr C(), Rc, n, r, vntIJK, Zan - 1
        Next
    End If
    
End Sub

Sub CallTest()   '一行目(A1,B1,C1,...)に元データ、A2に組合せに使用するデータ数、A3以降に組合せを表示する例
    Dim Source As Variant
    Dim A As Variant
    Dim R As Long, C As Integer
    Dim i As Long, j As Integer
    Dim B As Variant
    
    With ActiveSheet
        .UsedRange.Offset(2).Clear
        Source = .Range(.Cells(1), .Cells(1).End(xlToRight)).Value
        
        A = nCr(UBound(Source, 2), .Cells(2, 1).Value)
        
        R = UBound(A, 1)
        C = UBound(A, 2)
        
        MsgBox R
        
        Debug.Print R, C
        
        If R > 65534 Then
            MsgBox "多過ぎ!", vbExclamation
            Exit Sub
        End If
        
        ReDim B(1 To R, 1 To C)
        
        Application.ScreenUpdating = False
        For i = 1 To R
            For j = 1 To C
                B(i, j) = Source(1, A(i, j))
                'Debug.Print a(i, j),
            Next  ': Debug.Print
        Next
        .Cells(3, 1).Resize(R, C).Value = B
        Application.ScreenUpdating = True
    End With
   
End Sub
top

四捨五入 ― 数値を任意の有効桁数に四捨五入する
 ROUND ワークシート関数
Public Function SignificantFigures(Number, L) As Double
    '数値を有効数字L桁に四捨五入する
    If Number = 0 Then
        SignificantFigures = 0
    Else
        SignificantFigures = Application.Round(Number, -Int(Application.Log(Abs(Number))) - 1 + L)
    End If
End Function
top