ExcelVBAサンプル集

→ExcelのVBA

正規表現による倍角文字チェック†

Sub CheckFullWidthCharacters()
    Dim ws As Worksheet
    Dim cell As Range
    Dim lastRow As Long
    Dim fullWidthPattern As String
    Dim match As Object

    ' 使用するワークシートを設定
    Set ws = ActiveSheet

    ' C列の最終行を取得
   l astRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

    ' 全角文字を検出する正規表現パターン
   f ullWidthPattern = "[^\x00-\x7F]"

    ' C列のデータを一つずつチェック
    For Each cell In ws.Range("C1:C" & lastRow)
        If cell.Value <> "" Then
            cell.Select
           '  正規表現オブジェクトを作成
            With CreateObject("VBScript.RegExp")
               .Global = True
               .Pattern = fullWidthPattern
               ' パターンにマッチするかチェック
               Set match = .Execute(cell.Value)
               If match.Count > 0 Then
                   ' マッチする場合、セルの背景を赤色に設定
                   cell.Interior.Color = RGB(255, 0, 0)
               Else
                   ' マッチしない場合、セルの背景を緑色に設定
                   cell.Interior.Color = RGB(0, 255, 0)
               End If
           End With
       End If
       DoEvents
   Next cell
   MsgBox ("OK")
End Sub

開いているファイルの中から名前の左側が引数と合致するファイルを探す†

'２つ以上あったらエラー
Function schFile(name As String) As Workbook

    Dim cnt As Integer
    cnt = 0

    Set schFile = Nothing

    Dim bk As Workbook
    For Each bk In Workbooks
        Dim ln As Integer
        ln = Len(name)
        Debug.Assert (ln > 0)
        If StrConv(Left(bk.name, ln), vbUpperCase) = StrConv(name, vbUpperCase) Then
            If Not (schFile Is Nothing) Then
                MsgBox ("[" & name & "]で始まるファイルが２つ以上あります")
                End
            End If

            Debug.Assert (schFile Is Nothing)  '同じ名前で始まるファイルが２つ以上あったらエラーになります
            Set schFile = bk
            'ここですぐは返らない　２つ以上あったらまずいから
        End If
    Next

    If schFile Is Nothing Then
        MsgBox ("[" & name & "]で始まるファイルが見つかりません")
        End
    End If

End Function

countifsの数式を元に、同じ条件でフィルタをかける†

Sub 数式からフィルター(r As Range)
Dim strSuusiki As String
Dim varPrm As Variant
Dim sh As Worksheet
Dim ac As Worksheet
Dim lngLoop As Long
Dim lngColNo As Long
Dim strJoken As String
Dim rngFil As Range

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set sh = Sheets("hoge")
    Set ac = r.Worksheet

    strSuusiki = r.Formula ''該当セルの数式を取り出す
    strSuusiki = Replace(strSuusiki, "=countifs(", "", , , vbTextCompare) '’余分なところを消す
    strSuusiki = Replace(strSuusiki, "=countif(", "", , , vbTextCompare) '’余分なところを消す
    strSuusiki = Replace(strSuusiki, ")", "") '’余分なところを消す
    varPrm = Split(strSuusiki, ",") '’Countifsのパラメータのみを配列に分割する

    If Not sh.AutoFilterMode Then ''オートフィルターが付いてない場合
        Intersect(sh.UsedRange, sh.Range("10:65535")).AutoFilter '’フィルターをつける
    End If

    If sh.FilterMode Then '’フィルターがかかっている状態のときはフィルタークリア
        sh.ShowAllData
    End If

    Set rngFil = sh.AutoFilter.Range

    For lngLoop = 0 To UBound(varPrm) Step 2
        lngColNo = Range(varPrm(lngLoop)).Column    ''配列の偶数番目＝検索条件範囲のカラム番号を取得
        strJoken = varPrm(lngLoop + 1)              ''配列の奇数番目＝検索条件を取得
        If InStr(strJoken, """") > 0 Then
            strJoken = Replace(strJoken, """", "") '’""がある場合は定数（””は消す）
        Else
            strJoken = ac.Range(strJoken).Value '’””がない場合はセルへの参照のため参照先の値を取得
        End If


        rngFil.AutoFilter Field:=lngColNo, Criteria1:=strJoken
    Next

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

ハイパーリンクをクリックしたら上の行（３行目）にあげる†

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
   Dim r As Integer
   r = Target.Range.row
   If r = 3 Then
       Exit Sub
   Else
       ThisWorkbook.Worksheets(1).Activate
       Rows("3:3").Select
       Selection.EntireRow.Insert

       r = r + 1
       Rows(r & ":" & r).Select
       Selection.Cut
       Range("A3").Select
       ActiveSheet.Paste

       Range("A" & r).Select
       Selection.EntireRow.Delete
   End If
End Sub

Shift JIS文字列をUTF-8に†

Public Function encodeUTF8(ByRef strUni As String) As Byte()
   encodeUTF8 = ADOS_Encode("UTF-8", strUni)
End Function

Private Function ADOS_Encode(ByVal cset As String, ByRef strUni As String) As Byte()
   Dim objStm As ADODB.Stream
   Set objStm = New ADODB.Stream
   objStm.Open
   objStm.Type = adTypeText
   objStm.Charset = cset
   objStm.WriteText strUni

   objStm.Position = 0
   objStm.Type = adTypeBinary
   Select Case UCase(cset)
     Case "UNICODE", "UTF-16"
       objStm.Position = 2
     Case "UTF-8"
       objStm.Position = 3
   End Select
   ADOS_Encode = objStm.Read()

   objStm.Close

End Function

シート並べ替えサンプル†

• １シート目の2行目2列目からシート名を並べておき、その順番に２番目以降のシートを入れ替えるマクロの例（ちょっとバグってるかも…）

Sub シート並べ替え()

   Dim bk As Workbook
   Set bk = ThisWorkbook

   Dim sht As Worksheet
   Set sht = ActiveSheet

   Dim names() As String
   Dim i As Integer

   'シート名読み込み
   Dim j As Integer
   j = 0
   For i = 2 To 1000 'とりあえず1000シートまで
       If sht.Cells(i, 2) <> "" Then
           ReDim Preserve names(j)
           names(j) = sht.Cells(i, 2)
           j = j + 1
       Else
           Exit For
       End If
   Next

   For i = 0 To UBound(names)
       Dim wsht As Worksheet
       Set wsht = bk.Worksheets(names(i))
       Call wsht.Move(After:=bk.Worksheets(1 + i))
   Next

   MsgBox ("OK")

End Sub

ブックのシートインデックスを作る†

• 最初のシートに「目次」という名前をつけるのであらかじめ用意しておく

  Sub MakeIndex()
     
     Dim s_シート名() As String
     
     Dim mokuji As Worksheet
     Set mokuji = Worksheets(1)
     mokuji.Name = "目次"
     
     '《目次》シート情報
     Dim row As Integer
     Dim col As Integer
     row = 1
     col = 2
  
     '  シート名取得
     mokuji.Select
     Dim J As Integer
     For J = 1 To Worksheets.Count
         ReDim Preserve s_シート名(J)
         s_シート名(J) = Worksheets(J).Name
     Next J
     
     mokuji.Activate
  
     '  取得結果反映
     Dim K As Integer
     For K = 2 To UBound(s_シート名)
  
         Dim sht_name As String
         sht_name = s_シート名(K)
         If sht_name <> "" Then
             Dim rnt As Range
             Set rnt = mokuji.Cells(K, col)
             mokuji.Hyperlinks.Add _
                 Anchor:=rnt, _
                 Address:="", SubAddress:="'" & sht_name & "'!A1", TextToDisplay:=sht_name
             mokuji.Cells(K, col).Select
         End If
  
     Next K
  End Sub

シートに画像を取り込み、その占めている範囲の右下セルを得る†

Dim acs As Worksheet
Set acs = ActiveSheet
acs.Cells(1, 1).Select
acs.Pictures.Insert(画像のpath).Select
Dim r As Range
Set r = acs.Pictures(1).BottomRightCell

いらないシートを消す†

   Application.DisplayAlerts = False '警告抑制
   With outbook
       '本当は３つとは限らないが（Excelの設定によって変わるので）、とりあえず
       .Worksheets("Sheet1").Delete
       .Worksheets("Sheet2").Delete
       .Worksheets("Sheet3").Delete
   End With

• ※シート数を０にはできませんので注意

印刷改ページを調整する†

'印刷ブレーク位置微調整 13桁目だったら右に１つずらす
'直接指定できないのだろうか?
Function adjust_print(st As Worksheet) As Integer

        Debug.Print (st.Name)
        st.Activate
        st.Cells(1, 14).Select
        
        'これでは変わってくれないようだ
        If st.VPageBreaks.Count = 0 Then
            st.VPageBreaks.Add st.Range("N1")
        Else
            st.VPageBreaks(1).Location = st.Range("N1")
        End If
        
        'こうしないとあわせられないのだろうか?
        If st.VPageBreaks(1).Location.Column = 13 Then
            ActiveWindow.View = xlPageBreakPreview
            ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
            ActiveWindow.View = xlNormalView
        End If
        
        st.Cells(1, 1).Select

    adjust_print = 0
End Function

Sub 印刷位置合わせ()
'
    Dim shts As Sheets
    Set shts = ActiveWorkbook.Worksheets
    Dim i As Integer
    Dim st As Worksheet
    
    '対象シート毎
    For i = 4 To shts.Count
        Set st = shts(i)
        Call adjust_print(st)
        DoEvents
    Next
    
End Sub

ブックを開いてシート毎になにかするサンプル†

Function prcBook(bk As String) As Integer
    
    Debug.Print ("-------book:" & bk & "スタート---------------------")
    
    Dim wbk As Workbook
    '指定 xls を開く
    'Set wbk = Application.Workbooks(bk)
    Set wbk = Workbooks.Open(bk)
    wbk.Activate
    
    Dim cnt As Integer
    cnt = wbk.Worksheets.Count
    Debug.Assert (cnt > 0)
    Dim i As Integer
    For i = 1 To cnt
        Dim wst As Worksheet
        Set wst = wbk.Worksheets(i)
        
        Call prcSheet(wst)
        
    Next
    
    wbk.Close
    Debug.Print ("-------処理終わり---------------------")

End Function

現在見ているブックの全シートから_YMDHMSという値の入ったセルをすべて探し、その下にあるセルにフォーマットを設定する†

 Sub 日付のフォーマット修正()
   Debug.Print ("フォーマット修正開始")
   Dim bk As Workbook
   Dim sht As Worksheet
   Set bk = ActiveWorkbook
   Dim i As Integer
   For i = 1 To bk.Worksheets.Count
       Set sht = bk.Worksheets(i)
       With sht
           .Activate
           .Cells(1, 1).Select
           Dim r As Range
           Set r = Cells.Find(What:="_YMDHMS", After:=ActiveCell, LookIn:=xlValues, _
               LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
               MatchCase:=False, MatchByte:=False, SearchFormat:=False)
           If Not r Is Nothing Then
               Dim firstPos As String
               firstPos = r.Address
               Do
                   Dim s As String
                   .Cells(r.row, r.Column).Select
                   If Trim(.Cells(r.row + 1, r.Column)) <> "" Then
                       s = .Cells(r.row, r.Column)
                       Debug.Print (.Name & ":" & r.row & "," & r.Column & "," & s)
                       .Cells(r.row + 1, r.Column).NumberFormatLocal = "yyyy-mm-dd hh:mm:ss"
                       .Cells(r.row + 1, r.Column).HorizontalAlignment = xlLeft
                       Dim rcol As Range
                       Set rcol = .Columns(r.Column)
                       rcol.AutoFit
                   End If
                   Set r = Cells.FindNext(r)
                   DoEvents
               Loop While (r.Address <> firstPos)
           Else
               'そもそもない
           End If
       End With
   Next
   MsgBox ("OK")
 End Sub

パスワード付きでブックを保存する†

ActiveWorkbook.SaveAs Filename:= _
"hoge.xls", FileFormat:= _
xlExcel8, Password:="anestec", WriteResPassword:="", ReadOnlyRecommended _
:=False, CreateBackup:=False

ハイパーリンク作成†

表示文字列 = "hoge"
アドレス = "http://www.kernel-net.ne.jp/tech/"
Range("A1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, _
       Address:=アドレス, TextToDisplay:=表示文字列

• 削除

  Range("A1").Hyperlinks.Delete
  Range("A1").ClearContents

データが変わった切れ目で改ページ†

• http://oshiete1.goo.ne.jp/qa1919970.html

  Worksheets(SheetName).Range("B" + Trim$(Str$(rindex))).Activate
  ActiveWindow.SelectedSheets.HPageBreaks.Add ActiveCell '改ページ挿入
  ActiveWindow.SelectedSheets.VPageBreaks.Add ActiveCell

データのある最後の行を返す†

e=Worksheets("sheet1").Range("A1").End(xlDown).Row

もしくは

e=Worksheets("sheet1").Range("A65536").End(xlUp).Row 'データ中に空き行がある場合

• 上のやり方では、列なら２列以上ないと256が返ってしまうので、下記のようにやる方がいいようだ。

  Dim row As Integer
  row = sht.UsedRange.Cells(sht.UsedRange.Count).row
  
  Dim line As Integer
  line = sht.UsedRange.Cells(sht.UsedRange.Count).Column

• このやり方についてこちらのblog でご指摘あり。感謝

  これは、データの入力の有無に関わらず、セルの一部に書式設定などがされていれば、
  有効な範囲として値を返します。
  すっきりとしていて、うまく行きそうですが、実は落とし穴になっています。

最新の50件