Office関連メモ

Excel関連

C#によるExcel制御

Visual Basic(.NET以前)

関連Web

  • ExcelRelaxTools Addin 2014.1.29
    • 5年間(2009年〜)にわたって作成したマクロを汎用的、体系的にまとめたものです。

Tips

スクレイピング

アドイン関連

ExcelにGoogle Maps APIで地図を埋め込み、住所検索、拡大/縮小、地図種類変更

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

'2つ以上あったらエラー
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 & "]で始まるファイルが2つ以上あります")
                End
            End If

            Debug.Assert (schFile Is Nothing)  '同じ名前で始まるファイルが2つ以上あったらエラーになります
            Set schFile = bk
            'ここですぐは返らない 2つ以上あったらまずいから
        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

ハイパーリンクをクリックしたら上の行(3行目)にあげる

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

セルの値を文字列として取得したい場合

Cells(i,j).Text

フィルタ系

  • フィルタをクリアする
    ActiveSheet.ShowAllData

現在見ているブックの全シートから_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

今選択しているシート

  • Application.SelectedSheets を参照する

「名前」の全消し

  • メニューから消していると一回に1つしか消せなくて面倒なので、以下のマクロで
    for i = ActiveWorkbook.Names.Count to 1 step -1
      ActiveWorkbook.Names(i).Delete
    Next

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

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

手っ取り早くExcelシートの一覧を得るには

  • ALT+F11を押下(VBAエディタが起動)
  • CTRL+Gを押下(イミディエイトウインドウが起動)
    For Each i In ThisWorkbook.Sheets: debug.print i.name : next i 
    をタイプしてEnterを押下

[Esc]キーによるExcel VBAの実行中断を防止する

互換性チェックのダイアログが出るのを抑制

  • Office2007で .xlsファイルを保存しようとしたときに出るダイアログを抑制したい場合は、上書き確認の抑制と同じように
    Application.DisplayAlerts=False
    とする

Excelで特定の値になったときのアクション

  • 特定のセルに特定の値が入力されたときにマクロを自動的に実行するには?
    • http://www.asahi-net.or.jp/~zn3y-ngi/YNxv9c7.html
    • WorkSheet_Changeのイベントプロシージャに処理を書けば良い。当然ながらExcelの設定でマクロ実行を許可しておく必要はある(オプションのセキュリティ設定)

ツリービューコントロール

VBA コンパイルエラーと実行時エラー

CSVをUTF-8で保存する

  • 通常のSave機能ではUnicodeまでしか指定できないが、いくつか方法はある
  • フリーのモジュールを使用する方法
  • ADODB.Streamを使う方法
       Dim myFileName As String
       Dim myPath As String
       Dim NewFileName As String
       
       myFileName = ActiveWorkbook.name
       myPath = ActiveWorkbook.Path
       
       Dim outbook As Workbook
       Set outbook = ActiveWorkbook
       Dim sht As Worksheet
    
       Dim i As Integer
       For i = 1 To ActiveWorkbook.Worksheets.Count
           Windows(myFileName).Activate
           NewFileName = ActiveWorkbook.Worksheets(i).name
           Set sht = outbook.Worksheets(i)
           Dim StreamIn As Object
           Set StreamIn = CreateObject("ADODB.Stream")
           With StreamIn
               .Open
               .Charset = "shift_jis"
               .Type = 2
               .Position = 0
           End With
       
           Dim StreamOut As Object
           Set StreamOut = CreateObject("ADODB.Stream")
           With StreamOut
               .Open
               .Charset = "UTF-8"
               .Type = 2
               .Position = 0
           End With
       
           Dim row As Integer
           row = sht.UsedRange.Cells(sht.UsedRange.Count).row
    
           Dim line As Integer
           line = sht.UsedRange.Cells(sht.UsedRange.Count).Column
    
           Dim fileName As String
           fileName = myPath & "\" & NewFileName & ".dat"
    
           Dim r As Integer
           For r = 1 To row
               Dim l As Integer
               For l = 1 To line - 1
                   StreamIn.WriteText sht.Cells(r, l) & ","
               Next
               StreamIn.WriteText sht.Cells(r, line), 1
           Next
           
           StreamIn.SetEOS
           StreamIn.Position = 0
    
           StreamIn.CopyTo StreamOut
           StreamOut.SetEOS
           StreamOut.Position = 0
           
           StreamOut.SaveToFile fileName, 2
           StreamIn.Close
           StreamOut.Close
           Set StreamIn = Nothing
           Set StreamOut = Nothing
       Next i

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

描画抑制

Application.ScreenUpdating = false

シート並べ替えサンプル

  • 1シート目の2行目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

Excelシートアルファベット順並べ替え

シート上のシェイプの色をまとめて黒に戻す例

Sub Macro1()
   Dim i As Integer
   Dim acs As Worksheet
   Set acs = ActiveSheet
   For i = 1 To acs.Shapes.Count
       Dim shap As Shape
       Set shap = acs.Shapes(i)
       With shap
           acs.Activate
           shap.Select
           DoEvents
           If (shap.Type = msoAutoShape) Then
               If shap.AutoShapeType = msoShapeMixed Then
                   'コンピュータ図とか
               ElseIf shap.AutoShapeType = msoShapeRoundedRectangle Then
                   '角の丸い四角
                   Selection.Font.ColorIndex = xlAutomatic
               End If
               
           ElseIf shap.Type = msoLine Then
               Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
               Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
           
           ElseIf shap.Type = msoTextBox Then
               Selection.Font.ColorIndex = xlAutomatic
           End If
       End With
   Next
End Sub

列幅を合わせる

   'ost は対象シート
   ost.Activate
   ost.Range(ost.Cells(1, 1), ost.Cells(osr, 8)).Columns.AutoFit
  • columnsに対して行うのがポイント

マクロのあるブック

  • ThisWorkbookで参照

シェイプを最背面に移動

Selection.ShapeRange.ZOrder msoSendToBack '最背面に移動

AddTextBox に渡す座標の渡し方

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

  • 最初のシートに「目次」という名前をつけるのであらかじめ用意しておく
    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
       '本当は3つとは限らないが(Excelの設定によって変わるので)、とりあえず
       .Worksheets("Sheet1").Delete
       .Worksheets("Sheet2").Delete
       .Worksheets("Sheet3").Delete
   End With
  • ※シート数を0にはできませんので注意

プログラムの同期的な実行

表示倍率を変える

ActiveWindow.Zoom = 75

ハイパーリンク作成

表示文字列 = "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

印刷設定 右下にページ数を入れる

ActiveSheet.PageSetup.RightFooter = "&P/&N"

印刷範囲の設定

ActiveSheet.PageSetup.PrintArea = "$A$1:$N$83" 'A1形式 Rangeではダメです

RangeからA1形式の文字列を得るには

str = Cells(row, col).Address

Worksheets.AddのAfter引数などで渡すのはシート名ではない

  • シートの番目でもない。Worksheetのオブジェクトを渡さないといけないので注意
    'ブック末尾へのシート追加
    Worksheets.Add after:=Worksheets(Worksheets.Count)
  • Worksheet.Move や .Copyも同様

VBAでデータが変わった切れ目で改ページしたい

印刷改ページを調整する

'印刷ブレーク位置微調整 13桁目だったら右に1つずらす
'直接指定できないのだろうか?
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

CSV形式で保存する

ActiveWorkbook.SaveAs Filename:="hoge.csv", FileFormat:=xlCSV, CreateBackup:=False

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

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

もしくは

e=Worksheets("sheet1").Range("A65536").End(xlUp).Row 'データ中に空き行がある場合
  • 上のやり方では、列なら2列以上ないと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 でご指摘あり。感謝
    これは、データの入力の有無に関わらず、セルの一部に書式設定などがされていれば、
    有効な範囲として値を返します。
    すっきりとしていて、うまく行きそうですが、実は落とし穴になっています。

ゴールシークを実行させる

'E3の値が0になるようにB3を変化させる場合
Range("E3").GoalSeek Goal:=0, ChangingCell:=Range("B3")

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

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

トップ   編集 凍結 差分 バックアップ 添付 複製 名前変更 リロード   新規 一覧 単語検索 最終更新   ヘルプ   最終更新のRSS
Last-modified: 2020-10-04 (日) 23:59:37 (110d)