Excel VBA ノート(サンプルコード)

Hide Tamura の Excel VBA ノート

Excel-VBA Excel2016でもExcel2013のVBAプログラム(マクロ)は動くか

今まで Excel2013をメインに使用していましたが、office365をインストールして、Excel2016 にしました。

Excel2013と、Excel2016は、ひとつのパソコンに共存させることができません。
下位バージョンのoffice製品はアンインストールさせる必要がありますので、Accessは古いバージョンのまま・・・なんてことは出来ませんので注意が必要です。
つまり、Office製品をすべて 2016にバージョンにアップデートすることになります。


心配していたことは、Excel2013用に作ったVBAプログラムが、Excel2016 でも問題なく動くかどうか。

テストした結果・・・問題なく動作しました。

ユーザーフォーム、CSV書き出し/読み込み、ファイル操作などなど。どれも問題なし。


今後、Excel2016特有のトラブルが発生した場合には、このブログに書きたいと思います。



参考
Excel2016 の Application.Version は、16.0 でした。



Excel-VBA リストボック(ListBox)に絞り込み機能を追加 Find

uf3


リストボックスの上に絞り込み用のTextBoxを配置し、「ふりがな」で絞り込みを行う。
例では、商品テーブルの商品に「ふりがな」列を作っておき、絞り込みの文字(ひらがな)と比較する。


TextBoxの文字を一文字入力する度にListBox内のリストが絞り込まれる。逆に一文字づつ消しても同様。
全ての文字を消した場合には、ListBoxを初期状態へ再表示して全てのリストを表示する。

元の商品リストと別に、絞り込み用の表をプログラム内で作成し、それをListBoxに表示し直すので、元のリストは壊れない。


以下は、TextBoxに入力してListBoxが絞り込まれるプログラム。

===========================

Private Sub TextBox1_Change() 
    Dim r As Long
    Dim lngEndRow As Long

    Application.ScreenUpdating = False
    
    'テキストボックが空だったら、ListBoxに全てのリストを表示して終了
    If TextBox1.Text = "" Then
    
        r = Application.Rows.Count
        lngEndRow = Sheets(Sht_work2).Cells(r, "A").End(xlUp).Row
    
        If lngEndRow < 2 Then
            ListBox2.RowSource = ""
        Else
            ListBox2.RowSource = Sht_work2 & "!A2:B" & lngEndRow
        End If
    
        Exit Sub
    End If
    
    'テキストボックに入力があったら、絞り込みを行う
    Call 商品情報をふりがな入力で絞り込みLB1
    
End Sub

===========================

Sub 商品情報をふりがな入力で絞り込みLB1() 
    Dim strActiveCellAddress As String
    Dim strThisSheetName As String
    
    Dim r As Long
    Dim lngEndRow As Long
    Dim i As Long
    
    Dim Serch_ID As String
    Dim Dat_SerchArea As String
    Dim firstAddress As String
    Dim c As Range
    
    Application.ScreenUpdating = False
    
    strActiveCellAddress = ActiveCell.Address
    strThisSheetName = ActiveSheet.Name
    
    '--------------------------------------------------
    '       振込情報をワークシートにコピー
    '--------------------------------------------------
    
    '商品リストの最終行を求める
    r = Application.Rows.Count
    lngEndRow = Sheets(Sht_work2).Cells(r, "A").End(xlUp).Row

    '商品リストがない→終了
    If lngEndRow < 2 Then
        ListBox2.RowSource = ""
        Exit Sub
    End If

    '絞り込んだデータはJ:K列にコピーするので、コピー先をクリアしておく
    Sheets(Sht_work2).Columns("J:K").ClearContents

    '絞り込みキーワードをTextBoxから得る
    Serch_ID = TextBox1.Text
    
    '検索先の列を指定
    Dat_SerchArea = "C1:C" & lngEndRow

    '--------------------------------------------------
    ' TextBox1のTextと ふりがな が部分一致したらコピー
    '--------------------------------------------------
    
    i = 1
    
    '商品の表タイトルだけ先に絞り込み表へコピー
    Sheets(Sht_work2).Range("A" & i & ":C" & i).Copy
    Sheets(Sht_work2).Range("J" & i).PasteSpecial Paste:=xlValue
    Application.CutCopyMode = False
    
    '見出し部分を消して、見出し行から検索しないと並び順が狂う。
    Sheets(Sht_work2).Range("C1").ClearContents
    
    '絞り込み検索して部分一致した商品データを、絞り込み後の表へコピーしていく
    With Worksheets(Sht_work2).Range(Dat_SerchArea)
        
        Set c = .Find(Serch_ID, LookIn:=xlValues, lookat:=xlPart, matchbyte:=False)
        If Not c Is Nothing Then
        
            firstAddress = c.Address
            i = i + 1
            
            Sheets(Sht_work2).Range("A" & c.Row & ":C" & c.Row).Copy
            Sheets(Sht_work2).Range("J" & i).PasteSpecial Paste:=xlValue
            Application.CutCopyMode = False
                      
            Do
                
                Set c = .FindNext(c)
                
                If c.Address <> firstAddress Then
                    i = i + 1
                    Sheets(Sht_work2).Range("A" & c.Row & ":C" & c.Row).Copy
                    Sheets(Sht_work2).Range("J" & i).PasteSpecial Paste:=xlValue
                    Application.CutCopyMode = False
                End If
            
            Loop While Not c Is Nothing And c.Address <> firstAddress

        End If
    
    End With

    '絞り込み後の表の最終行を確認し、一致したデータあった場合は、ListBoxに再表示
    lngEndRow = Sheets(Sht_work2).Cells(r, "J").End(xlUp).Row
    If lngEndRow < 2 Then
        ListBox2.RowSource = ""
    Else
        ListBox2.RowSource = Sht_work2 & "!J2:K" & lngEndRow
    End If
    
    Sheets(strThisSheetName).Select
    Range(strActiveCellAddress).Select
    
End Sub

Excel-VBA リストボック(ListBox)に複数の項目(フィールド)を登録、表示上は特定の項目のみにする ListBox ColumnWidths ListBox1.List(行,列)

UserFormのイニシャライズの際にA列~H列の8つの項目のリストをListBox1に登録。
UserForm3.ListBox1.RowSource = Sht_work1 & "!A2:H" & (lngEndRow - 1)
※Sht_work1 と lngEndRow は変数。

その際に、左から2つの項目(振込先コード、振込先名)だけリストに表示。
ListBox1 のプロパティで、ColumnWidths を次のように設定

30 pt;150 pt;0 pt;0 pt;0 pt;0 pt;0 pt;0 pt


ListBox1のリストをクリックした時には、ListBoxに表示していないデータもセルに転記します。

Private Sub ListBox1_Click()
    Dim lngListIndex As Long

    Application.ScreenUpdating = False

    lngListIndex = Me.ListBox1.ListIndex

    Cells(ActiveCell.Row, "F").Value = Me.ListBox1.List(lngListIndex, 0) '振込先コード
    Cells(ActiveCell.Row, "G").Value = Me.ListBox1.List(lngListIndex, 1) '振込先名
    Cells(ActiveCell.Row, "M").Value = Me.ListBox1.List(lngListIndex, 3) '銀行
    Cells(ActiveCell.Row, "N").Value = Me.ListBox1.List(lngListIndex, 4) '支店
    Cells(ActiveCell.Row, "O").Value = Me.ListBox1.List(lngListIndex, 5) '種
    Cells(ActiveCell.Row, "P").Value = Me.ListBox1.List(lngListIndex, 6) '口座番号
    Cells(ActiveCell.Row, "Q").Value = Me.ListBox1.List(lngListIndex, 7) '口座名

End Sub


Excel-VBA UserFormとExcelブックを並べて表示 Application.Left Application.Top

userfrom3


Sub UF3Show() '★

    'ユーザーフォームを表示する
    UserForm3.Show
    
    '==================================================
    
    ' ウインドウの位置とユーザーフォームの位置の調整
        
    '==================================================

    'Excel2013より前のバージョンはウインドウの中でブックを最大化する
    '(Excel2013からはブックごとにウインドウが異なる)
    If Application.Version < 15 Then
        ActiveWindow.WindowState = xlMaximized
    End If

    'WindowStateをノーマルにしてフローティング状態にする(最大でも最小でもない)
    Application.WindowState = xlNormal

    'Excelウインドウの左にらUserFormの幅分(220)の隙間を空ける
    If Application.Left < 220 Then Application.Left = 220

    '------------------------------
    'UserForm3の表示位置の設定

    'UserFormをExcelウインドウより少し下げる
    UserForm3.Top = Application.Top + 5
    
    'UserFormをExcelウインドウからUserFormの幅分分(220)だけ左に表示
    UserForm3.Left = Application.Left - 220

End Sub

 

Excel-VBA 銀行口座名から振込用のカタカナ口座名を作る Phonetic オブジェクト, Replace関数

銀行口座名の「ふりがなテキスト文字列」から、振込用のカタカナ口座名を作る。
㈱や㈲は、カ)や、ユ)に変換する必要がある。


Dim Kouzamei As String

'入力した際の 「ふりがなテキスト文字列」が無ければ終了
If Cells(ActiveCell.Row, "C").Phonetic.Text = "" Then Exit Sub

'振込用口座名入力がまだ無い場合に行う。既に入力されていたら何もしない。
If Cells(ActiveCell.Row, "I").Value = "" Then
    
    '口座名をフリガナに変換して変数にもつ(「ふりがなテキスト文字列」を使用する)
    Kouzamei = StrConv(Cells(ActiveCell.Row, "C").Phonetic.Text, vbKatakana)

    '振込用口座名の場合は、㈱や㈲をカタカナ表記に変える
    If Right(Kouzamei, 1) = "㈱" Then Kouzamei = Replace(Kouzamei, "㈱", "(カ")
    If Left(Kouzamei, 1) = "㈱" Then Kouzamei = Replace(Kouzamei, "㈱", "カ)")
    If Right(Kouzamei, 4) = "(カブ)" Then Kouzamei = Replace(Kouzamei, "(カブ)", "(カ")
    If Left(Kouzamei, 4) = "(カブ)" Then Kouzamei = Replace(Kouzamei, "(カブ)", "カ)")
    If Right(Kouzamei, 4) = "(カブ)" Then Kouzamei = Replace(Kouzamei, "(カブ)", "(カ")
    If Left(Kouzamei, 4) = "(カブ)" Then Kouzamei = Replace(Kouzamei, "(カブ)", "カ)")
    
    If Right(Kouzamei, 1) = "㈲" Then Kouzamei = Replace(Kouzamei, "㈲", "(ユ")
    If Left(Kouzamei, 1) = "㈲" Then Kouzamei = Replace(Kouzamei, "㈲", "ユ)")
    If Right(Kouzamei, 4) = "(ユウ)" Then Kouzamei = Replace(Kouzamei, "(ユウ)", "(ユ")
    If Left(Kouzamei, 4) = "(ユウ)" Then Kouzamei = Replace(Kouzamei, "(ユウ)", "ユ)")
    If Right(Kouzamei, 4) = "(ユウ)" Then Kouzamei = Replace(Kouzamei, "(ユウ)", "(ユ")
    If Left(Kouzamei, 4) = "(ユウ)" Then Kouzamei = Replace(Kouzamei, "(ユウ)", "ユ)")
    
    '振込口座名を表示する
    Cells(ActiveCell.Row, "I").Value = Kouzamei

End If

 

Excel-VBA 並べ替え用の「ふりがな」を隣のセルに自動表示。 Phonetic オブジェクト, Replace関数

並べ替え用の「ふりがな」を隣のセルに自動表示します。

指定されたセルの「ふりがなテキスト文字列」を右隣のセルに表示します。
(コピーした場合など、指定されたセルに「ふりがなテキスト文字列」が無いこともあります。)

方法
まず、指定したセルに「ふりがなテキスト文字列」があるかどうか。
あれば、「ふりがなテキスト文字列」を変数に入れる。
並べ替えには、変数から、㈱や㈲などは邪魔なので消す。
右隣のセルに、ふりがなを表示する。
ただし、並べ替えに適した「ふりがな」を手入力している場合もあるので、既に入力があれば、なにもしない。


Dim Furigana As String

'入力した際の 「ふりがなテキスト文字列」が無ければ終了
If Cells(ActiveCell.Row, "C").Phonetic.Text = "" Then Exit Sub

'ふりがな列のセルに入力が無ければ、以下を行う(既に手入力されていたら何もしない)
If Cells(ActiveCell.Row, "D").Value = "" Then
    
    ' 「ふりがなテキスト文字列」を変数に持つ
    Furigana = StrConv(Cells(ActiveCell.Row, "C").Phonetic.Text, vbHiragana)
    
    '並べ替えの際に邪魔になる ㈱や㈲を消す
    Furigana = Replace(Furigana, "㈱", "")
    Furigana = Replace(Furigana, "(株)", "")
    Furigana = Replace(Furigana, "㈲", "")
    Furigana = Replace(Furigana, "(有)", "")
    Furigana = Replace(Furigana, "(有)", "")
    Furigana = Replace(Furigana, "(かぶ)", "")
    Furigana = Replace(Furigana, "(かぶ)", "")
    Furigana = Replace(Furigana, "(ゆう)", "")
    Furigana = Replace(Furigana, "(ゆう)", "")
    
    'ふりがなを ふりがな列に表示する
    Cells(ActiveCell.Row, "D").Value = Furigana

End If


Excel-VBA セル範囲を検索して関連する複数のデータを転記 Range.Find メソッド(VLOOKUPやHLOOKUPは使わない)

コード番号を入力することで、複数の関連情報を転記する時に利用します。
使用頻度の高く、重要度の高いサンプルコードです。

ExcelVBAリファレンスに「Findメソッド」の使用例が次のように出ています。

------------------------------
セル範囲内で特定の情報を検索します。

シート 1 のセル範囲 A1:A500 で、値に 2 が含まれているセルを検索し、その値を 5 に変更します。

With Worksheets(1).Range("a1:a500") 
    Set c = .Find(2, lookin:=xlValues) 
    If Not c Is Nothing Then 
        firstAddress = c.Address 
        Do 
            c.Value = 5 
            Set c = .FindNext(c) 
        Loop While Not c Is Nothing And c.Address <> firstAddress 
    End If 
End With
------------------------------

上記の例から、次のように書き換えて利用しています。

アクティブシートに振込先コードを入力し、振込先情報シートから関連情報を転記する例です。

Public Const Sht_furikomi As String = "振込先"

Sub 振込先コードto振込先情報()
    
    '検索に利用する変数
    Dim Serch_ID As String
    Dim Dat_SerchArea As String
    Dim c As Range
    
    Application.ScreenUpdating = False
        
    '振込先情報シートで検索するセル範囲(振込先コードがある列)
    Dat_SerchArea = "B:B"
    
    '検索する振込先コード番号を取得
    Serch_ID = ActiveSheet.Range("F" & ActiveCell.Row).Value

    'Serch_ID が無ければ終了(Val関数で0なら入力なしとする)
    If Val(Serch_ID) = 0 Then Exit Sub
                                                        
    With Worksheets(Sht_furikomi).Range(Dat_SerchArea)
        
        'lookat:=xlWhole で完全一致、xlPart なら部分一致
        Set c = .Find(Serch_ID, LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
                                        
            '振込先情報シートから、アクティブシートに関連情報を転記する
            With ActiveSheet
                .Range("G" & ActiveCell.Row).Value = Sheets(Sht_furikomi).Range("C" & c.Row).Value '振込先
                .Range("M" & ActiveCell.Row).Value = Sheets(Sht_furikomi).Range("E" & c.Row).Value '銀行
                .Range("N" & ActiveCell.Row).Value = Sheets(Sht_furikomi).Range("F" & c.Row).Value '支店
                .Range("O" & ActiveCell.Row).Value = Sheets(Sht_furikomi).Range("G" & c.Row).Value '種
                .Range("P" & ActiveCell.Row).Value = Sheets(Sht_furikomi).Range("H" & c.Row).Value '口座番号
                .Range("Q" & ActiveCell.Row).Value = Sheets(Sht_furikomi).Range("I" & c.Row).Value '口座名
            End With
        
        End If
    
    End With
    
End Sub

Excel-VBA データ入力便利機能: 表の最終列まで来たら、次行の開始列へ移動し、罫線も自動で追加する Worksheet_SelectionChange

まず・・・

あるタイミングで、Enterキーを押した後の、セルの移動方向を右に行くように変更しておきます。

    'セルの移動方向 右
    Application.MoveAfterReturnDirection = xlToRight

元に戻す時は、

    'セルの移動方向 下(標準)に戻す
    Application.MoveAfterReturnDirection = xlDown
    

------------------------------------------------------------------------

下の例では、表のL列まで来たら、次行のC列に移動し、罫線も自動で追加しています。

プログラム書く場所は、ワークシート・モジュール内
「VBAProject」→「Microsoft Excel Objects」→「Sheet1(など)」

「Sheet1」モジュールの上部左のリストから「Worksheet」を
「Sheet1」モジュールのの上部右のリストから「SelectionChange」を選択します。

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

        Select Case ActiveCell.Column
    
            'L列(12) まで来たら(表はK列まで)
            Case 12

                '最左へスクロールを動かす
                ActiveWindow.ScrollColumn = 1
                
                Call 罫線引き
    
        End Select
        
End Sub

------------------------------------------------------------------------

以下は、標準モジュールの中に書きます。
「VBAProject」→「標準モジュール」→「Module1(など)」

Sub 罫線引き()
        
    Range(Cells(ActiveCell.Row + 1, "C"), Cells(ActiveCell.Row + 1, "K")).Select
    
    Call 罫線

    '選択セル範囲の一番目を選択(C列)
    Selection.Cells(1).Select

End Sub

Sub 罫線()

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = -13312
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = -13312
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = -13312
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = -13312
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Color = -13312
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Color = -13312
        .TintAndShade = 0
        .Weight = xlThin
    End With

End Sub

上の「罫線」のプログラムについては、「マクロの記録」機能を使って自動で作成するのが楽です。その中から、セル範囲の選択部分を消去します。セル範囲の選択だけ変更することで、この部分は何度も利用できますから。


Excel-VBA フォントの色によって処理を変える ActiveCell.Font.Color

セルのフォントの色によって処理を変えたいという質問がありまして・・・

Sub Macro1()

    'フォントの色によって処理を変える
    Select Case ActiveCell.Font.Color
    
        Case vbBlack
        
            MsgBox "黒・自動"
                
        Case vbWhite
        
            MsgBox "白"
        
        Case vbRed
    
            MsgBox "赤"
    
    End Select
    
End Sub


Excel-VBA ソフト作り パブリック定数 : ワークシート名や、表の見出し行(列)番号、特定セル番号 の変更に備える Public Const

ワークシート名や、表の見出し行(列)番号、特定セルなどは、変更になる場合があります。

その際には、「全て置換」で書き換えするのではなく、予めパブリック定数にしておく事で、修正を一カ所で済むようにしておく。

私の場合は、新たに標準モジュールを挿入し、オブジェクト名を「Module0」に変更して、その中にマトメて設定しています。


例えば・・・ Module0 の中を、

------------------------------------------------------

'ワークシート定数
Public Const Sht_data As String = "データ"
Public Const Sht_furikomi As String = "振込先"
Public Const Sht_shohin As String = "商品"
Public Const Sht_work1 As String = "work1"
Public Const Sht_work2 As String = "work2"
Public Const Sht_CSV As String = "csv"

'ワークシート行設定(見出し行)
Public Const TitleRow_Sht_Data As Long = 6
Public Const TitleRow_Sht_furikomi As Long = 3
Public Const TitleRow_Sht_shohin As Long = 3

'フラグ用変数
Public blnSelectionChangeFlag As Boolean
Public blnCellColorFlag As Boolean

------------------------------------------------------

のように。



パブリック以外で使用する定数・変数は、各モジュール内、各プロシージャ内で宣言しています。
これで、急に、シート名が変更になっても慌てません。(^^♪

 


記事検索
Excel VBA ノートについて(注意事項)
このExcel VBA ノートは、Hide Tamura の個人的なVBAノートです。プログラムを再利用したり、コピペで入力の手間を省く為に作ったネット上のノートです。 その為、詳しい解説は書いておりません。エラー等のトラブルには責任は負いません。利用者の環境に合わせて書き換えてご利用ください。
ExcelVBA教室
Excel VBA 担当 Hide Tamura

Excel95? マクロシートがあった頃からExcelVBAを独学で利用しています。現在は、様々な企業様からVBAによる業務効率UPの為のお仕事を頂いております。既にお使いになっているファイルにVBAを利用することで、作業が楽になったり、時間も大幅に短縮されたなど、大変喜ばれています。

■VBA Expert
VBA Expert Standard Crown
ExcelVBA Standard(Odyssey)
Access VBA Standard(Odyssey)
Excel2002 VBA Standard(日本VBA協会)
■MICROSOFT OFFICE USER SPECIALIST
Microsoft Excel version2002 Expert
Microsoft Excel version2002


最新記事
Excelで作る経営計画
Excelで利益計画を立てましょう!会社にいくらの利益が必要で、その為の売上高は?

Excelで作る経営計画
Excel 関数 ノート
Excel関数を中心に、Excelの便利機能や、意外としらない使い方など書いていきます。

Excel 関数 ノート
Access VBAノート
Hide Tamura の個人的なVBAノートです。

頻繁に使うVBAコードなどを記録しコピペして使う為に作りました。お役に立てるようでしたら、お使いください。

Access VBAノート
アクセスカウンター

    • ライブドアブログ