Office関連メモ

Excel関連

C#によるExcel制御

Visual Basic(.NET以前)

サブトピック

一般

Tips

添付ファイルをつけてメール

画面をキャプチャする

Googleマップ表示

CSVやExcelにSQLを実行

マクロの自動実行を抑制

警告抑制

Application.DisplayAlerts = False '警告抑制

ファイルダイアログ(オープン)

   Dim dlg As FileDialog
   Set dlg = Application.FileDialog(msoFileDialogOpen)
   dlg.InitialFileName = "C:\Windows\"
   dlg.Show 'execute だと開く所までやってくれる
   
   Cells(1, 1) = dlg.SelectedItems(1)

スクレイピング

アドイン関連

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

フィルタ系

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

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

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

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

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

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

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

CSVをUTF-8で保存する

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

シート並べ替えサンプル

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シートアルファベット順並べ替え

列幅を合わせる

   'ost は対象シート
   ost.Activate
   ost.Range(ost.Cells(1, 1), ost.Cells(osr, 8)).Columns.AutoFit

マクロのあるブック

AddTextBox に渡す座標の渡し方

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

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

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

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

表示倍率を変える

ActiveWindow.Zoom = 75

ハイパーリンク作成

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

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

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

印刷範囲の設定

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

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

str = Cells(row, col).Address

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

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 'データ中に空き行がある場合

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

'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

VBAプロジェクトをロックする

VBAファイルのデータ構造


トップ   新規 一覧 検索 最終更新   ヘルプ   最終更新のRSS