→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で地図を埋め込み、住所検索、拡大／縮小、地図種類変更†

↑

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

'２つ以上あったらエラー
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
↑

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

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
       '本当は３つとは限らないが（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桁目だったら右に１つずらす
'直接指定できないのだろうか?
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