home HinoADO
Menu

JW_CADで外部変形等を作成する際にエクセルで用いるプロシージャ集の備忘録

jwc_temp.txt解析

外変か編集モードかを判断する

Private Sub Workbook_Open()
  If Dir(ThisWorkbook.Path & "/jwc_temp.txt") <> "" Then
    a = FileDateTime(ThisWorkbook.Path & "/jwc_temp.txt")
    If Abs(DateDiff("s", Now(), a)) < 10 Then main
  End If
End Sub

起動時に現在時刻とjwc_temp.txtのタイムスタンプを比較して、10秒以内なら外変として起動し、それ以外ならマクロを実行しないプロシージャ。
ThisWorkBookに記述する。

アクティブスケール取得

 Sub Get_Scale(Active_Scale)
 Application.StatusBar = "スケールを取得しています"
 Set tf = CreateObject("Scripting.FileSystemObject")
 Set tf_txt = tf.OpenTextFile(ThisWorkbook.Path & "\jwc_temp.txt", 1, True)
 Do Until tf_txt.AtEndOfStream
    tmp = tf_txt.readline                       '1行読み込み
    If Left(tmp, 2) = "hs" Then scale_tmp1 = Split(tmp, " ")
    If Left(tmp, 2) = "lg" Then
        scale_tmp2 = Val("&H" & Right(tmp, 1)) + 1
        Active_Scale = scale_tmp1(scale_tmp2)
        Exit Do
    End If
 Loop
 End Sub

作業ファイルのフォルダパスを取得

REM  #hf

が必要

Sub Get_jwc_temp_path(currentpath)
  'Call Get_jwc_temp_path(currentpath)
  '最後に「¥」を付加済
  Set tf = CreateObject("Scripting.FileSystemObject")
  Set tf_txt = tf.OpenTextFile(ThisWorkbook.Path & "\jwc_temp.txt", 1, True)
  Do Until tf_txt.AtEndOfStream
    tmp = tf_txt.readline
    If Left(tmp, 5) = "file=" Then
      a = Right(tmp, Len(tmp) - 5)
      b = Split(a, "\")
      c = ""
      For i = 0 To UBound(b) - 1
        c = c & b(i) & "\"
      Next
      currentpath = c
      MsgBox c
      End
    End If
  Loop
End Sub

ファイル名を含むフルパスを取得(#hfが指定された場合)

 Sub Get_Path(File_Path)
 'パスを取得(#hfが指定された場合)
 'Call Get_Path(File_Path)
 Set tf = CreateObject("Scripting.FileSystemObject")
 pth = ThisWorkbook.Path
 Set tf_txt = tf.OpenTextFile(pth & "\jwc_temp.txt", 1, True)
 Do Until tf_txt.AtEndOfStream
    tmp = tf_txt.readline                       '1行読み込み
    If Left(tmp, 5) = "file=" Then
        File_Path = Right(tmp, Len(tmp) - 5)
        Exit Do
    End If
 Loop
 End Sub

作図基点を取得

hpに求める基点の番号を指定し戻り値のx0,y0を記してCallで呼びます。
ex:

 Call Get_hp(2 ,x0 ,y0)
 Sub Get_hp(hp, x, y)
 Application.StatusBar = "基点を取得しています"
 Set tf = CreateObject("Scripting.FileSystemObject")
 pth = ThisWorkbook.Path
 Set tf_txt = tf.OpenTextFile(pth & "\jwc_temp.txt", 1, True)
 Do Until tf_txt.AtEndOfStream
    tmp = tf_txt.readline                       '1行読み込み
    If Left(tmp, 3) = "hp" & Right(Str(1), 1) Then
        kiten_tmp = Split(Right(tmp, Len(tmp) - 6))
        x = Val(kiten_tmp(0))
        y = Val(kiten_tmp(1))
        Exit Do
    End If
 Loop
 End Sub

アクティブグループを取得

Call Get_Active_Group(AG)
Sub Get_Active_Group(AG)
'アクティブグループを取得
Set tf = CreateObject("Scripting.FileSystemObject")
Set tf_txt = tf.OpenTextFile(ThisWorkbook.Path & "\jwc_temp.txt", 1, True)
Do Until tf_txt.AtEndOfStream
   tmp = tf_txt.readline                       '1行読み込み
   If Left(tmp, 2) = "lg" Then
       AG = tmp
       Exit Do
   End If
Loop
End Sub

jwc_temp.txt内から線色定義を探す

 Sub linecolor_get(tmp, lc_tmp)
 'jwc_temp.txt内から線色定義を探す
    Dim a, b
    a = Split(tmp)                          'スペースで切り分け
    b = UBound(a)                           '切り分けられた区分数を取得
    If b = 0 And Left(a(0), 2) = "lc" Then  '線色定義文字列の場合
        lc_tmp = Right(a(0), 1)             '線色を「lc_tmp」に格納
    End If
 End Sub

jwc_temp.txt内から線種定義を探す

 Sub linetype_get(tmp, lt_tmp)
 'jwc_temp.txt内から線種定義を探す
    Dim a, b
    a = Split(tmp)                          'スペースで切り分け
    b = UBound(a)                           '切り分けられた区分数を取得
    If b = 0 And Left(a(0), 2) = "lt" Then  '線種定義文字列の場合
        lt_tmp = Right(a(0), 1)             '線種を「lt_tmp」に格納
    End If
 End Sub

jwc_temp.txt内からレイヤグループ定義を探す

 Sub group_get(tmp, lg_tmp)
 'jwc_temp.txt内からレイヤグループ定義を探す
    Dim a, b
    a = Split(tmp)                          'スペースで切り分け
    b = UBound(a)                           '切り分けられた区分数を取得
    If b = 0 And Left(a(0), 2) = "lg" Then  'レイヤグループ定義文字列の場合
        lg_tmp = Right(a(0), 1)             'レイヤグループ番号を「ly_tmp」に16進数で取得
    End If
 End Sub

jwc_temp.txt内からレイヤ定義を探す

 Sub layer_get(tmp, ly_tmp)
 'jwc_temp.txt内からレイヤ定義を探す
    Dim a, b
    a = Split(tmp)                          'スペースで切り分け
    b = UBound(a)                           '切り分けられた区分数を取得
    If b = 0 And Left(a(0), 2) = "ly" Then  'レイヤ定義文字列の場合
        ly_tmp = Right(a(0), 1)             'レイヤを「ly_tmp」に格納
    End If
 End Sub

文字種からサイズを取得

 Sub Get_ch_size(no, cw, ch, cd)
 '文字種2を取得する場合は
 'Call Get_ch_size(2, hcw, hch, hcd)
 Set tf = CreateObject("Scripting.FileSystemObject")
 Set tf_txt = tf.OpenTextFile(ThisWorkbook.Path & "\jwc_temp.txt", 1, True)
 Do Until tf_txt.AtEndOfStream
    tmp = tf_txt.readline                       '1行読み込み
    If Left(tmp, 3) = "hcw" Then
        cw_tmp = Split(tmp)
        cw = Val(cw_tmp(no))
        tmp = tf_txt.readline
        ch_tmp = Split(tmp)
        ch = Val(ch_tmp(no))
        tmp = tf_txt.readline
        cd_tmp = Split(tmp)
        cd = Val(cd_tmp(no))
        Exit Do
    End If
 Loop
 End Sub

ファイル処理

外部テキストファイルの参照

 Dim tf
 Set tf = CreateObject("Scripting.FileSystemObject")
 Set tf_txt = tf.OpenTextFile(thisworkbook.path & "\jwc_temp.txt", 1, True)
 Do Until tf_txt.AtEndOfStream
   tmp = tf_txt.readline    '1行読み込み
     'ここに処理を記述
 Loop

テキストファイルの書き出し

 Dim fs
 Dim jwtmp
 Set fs = CreateObject("Scripting.FileSystemObject")
 Set jwtmp = fs.CreateTextFile("jwc_temp.txt", True)
    jwtmp.writeline("書き出す内容")
 jwtmp.close

ファイルの有無をチェック

If fso.FolderExists(full_path) Then
  Call Shell("explorer.exe  " & full_path, 1)
Else
  MsgBox ("No exist")
End If
  If Dir("ファイルのフルパス" ) <> "" Then
    MsgBox "Exist"
  Else
    MsgBox "No exist"
  End If

ファイルリスト取得

Sub カレントフォルダ内でxlsファイルを探す()
  Columns("A:A").ClearContents
    Dim Path_name As String
    Dim File_name As String
    Dim row As Long
    row = 1
    Path_name = ThisWorkbook.Path
    File_name = Dir(Path_name & "\*.*", vbNormal)
    Do While File_name <> ""
      row = row + 1
      Cells(row, 1).Value = File_name
      File_name = Dir()
    Loop
End Sub

フォルダの有無をチェック

  If Dir("フォルダのフルパス", vbDirectory ) <> "" Then
    MsgBox "Exist"
  Else
    MsgBox "not Exist"
  End If

フォルダを作成する

CHDirでカレントフォルダを設定可。フルパス表記も可。

MkDir "フォルダ名"

フォルダを開く

Shell "explorer " & フォルダ名, vbNormalFocus

ファイルを開く

Shell "explorer " & ファイル名, vbNormalFocus

ファイルをコピー

FileCopy ファイル名

ファイル名を変更してコピーする場合は

FileCopy ファイル名 , 変更後のファイル名

バックアップを作成

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
path1 = ThisWorkbook.Path & "\bak"
  If Dir(path1, vbDirectory) = "" Then
    MkDir path1
  End If
path2 = ThisWorkbook.Path & "\bak\" & Replace(Date, "/", "") & "_" & ThisWorkbook.Name
ThisWorkbook.SaveCopyAs path2
End Sub

ThisWorkBook内に記述。
上記のプロシージャではカレントフォルダ内に「bak」フォルダを(無ければ)作成し、ファイル名のヘッダに「日付」を付けて保存している。
一日作業分の最終上書き直前のファイルを退避させている。
保存間隔を時間単位にするときなどは調整が必要。

テキストファイルを文字コードUTF-8N指定で出力する

  'オブジェクトを作成
    Dim tmp_txt As Object
    Set tmp_txt = CreateObject("ADODB.Stream")
  'オブジェクトに保存するデータの種類を文字列型に指定する
    tmp_txt.Type = 2
  '文字列型のオブジェクトの文字コードを指定する
    tmp_txt.Charset = "UTF-8"
  'オブジェクトのインスタンスを作成
    tmp_txt.Open
    'ファイル内容をtmp_txtに格納
    tmp_txt.WriteText "", 1
    tmp_txt.WriteText "require 'sketchup.rb'", 1
  'オブジェクトの内容をファイルに保存
    '念のため最後に空白行を格納
      tmp_txt.WriteText "", 1
      tmp_txt.SaveToFile file_name, 2
    '先頭のBOM取り(UTF-8 -> UTF-8N)
      Dim bytData() As Byte
      With tmp_txt
        .Position = 0
        .Type = 1
        .Position = 3
        bytData = .Read
        
        .Position = 0
        .Type = 1
        .Write bytData
        .SaveToFile file_name, 2
        .Close
      End With
  'メモリからオブジェクトを削除する
    Set tmp_txt = Nothing

関数

Format関数

 Format(5459.4,"##,##0.00")

さらに詳細はこちら

General Number指定された数値をそのまま返します。例:MsgBox Format(100000,"General Number") → 100000
Currency通貨や1000単位の区切り記号などを、スタートメニューの「設定」「コントロールパネル」「地域」を選択して、「通貨タブ」で設定された書式に変換した値を返します。例:MsgBox Format(100000,"Currency") → \100,000
Fixed整数部を最低 1 桁、小数部を最低 2桁表示する書式に変換した値を返します。例:MsgBox Format(1000.234,"Fixed") → 1000.23
Standerd整数部を最低 1 桁、小数部を最低 2桁表示する書式に変換した値を返します。(1000単位の区切り記号・・・「 , 」を付けます。例:MsgBox Format(1000.234,"Standard") → 1,000.23
Percent指定された数値を100倍して、小数部を最低 2桁表示する書式に変換した値を返します。(1000単位の区切り記号・・・「 , 」を付けます例:MsgBox Format(0.234,"Percent") → 23.40%
Scientific標準的な科学記法の書式に変換した値を返します。例:MsgBox Format(0.234,"Scientific") → 2.34E-01
Yes/No指定された値が 0 の場合は No、それ以外の場合にはYes を返します。例:MsgBox Format(0,"Yes/No") → No
True/False指定された値が 0 の場合は (False)、それ以外の場合には(True) を返します。例:MsgBox Format(0,"True/False") → FALSE
On/Off指定された値が 0 の場合はOff、それ以外の場合には On を返します。例:MsgBox Format(0,"On/Off") → Off
Scientific標準的な科学記法の書式に変換した値を返します。例:MsgBox Format(0.234,"Scientific") → 2.34E-01
0000指定された値が 指定した桁数以下の場合0を付した書式に変換した値を返します。例:MsgBox Format(411,"0000")
++++指定された値の整数部を返します。例:MsgBox Format(411,"####") → 411
0.00指定された値を指定した少数桁表示する書式に変換した値を返します。例:MsgBox Format(196.5,"0.00") → 196.50
0%指定された値を %に変換した値を返します。例:MsgBox Format(0.35,"0%") → 35%

ソリッド色コードをRGB(Dec)に変換

Sub solidcode_to_rgb(clr, r, g, b)
'Call solidcode_to_rgb(clr, r, g, b)
  clrhex = Hex(clr)
  clrhex = String(6 - Len(clrhex), "0") & clrhex
  r = CLng("&H" & Mid(clrhex, 5, 2))
  g = CLng("&H" & Mid(clrhex, 3, 2))
  b = CLng("&H" & Mid(clrhex, 1, 2))
End Sub

線分の長さ

  lngth = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ 0.5

線分と任意の点に対する垂線の交点

call vertical_cross(x1,y1,x2,y2,px,py,vx,vy)
sub vertical_cross(x1,y1,x2,y2,px,py,vx,vy)
  '任意の点から線分に下ろした垂線の交点座標
  vx = ((py - y1) * (y1 - y2) * (x1 - x2) + px * (x1 - x2) ^ 2 - x1 * (y1 - y2) ^ 2) / ((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
  vy = ((px - x1) * (x1 - x2) * (y1 - y2) + py * (y1 - y2) ^ 2 - y1 * (x1 - x2) ^ 2) / ((y1 - y2) ^ 2 + (x1 - x2) ^ 2)
end sub

バブルソート

値の小さい方が若い番号に格納されます

  For i = 1 To D - 1
    For j = i To D
      If Dt(i) > Dt(j) Then
        Tp = Dt(i)
        Dt(i) = Dt(j)
        Dt(j) = Tp
      End If
    Next j
  Next i

点が多角形の内部にあるか

 Sub in_out_check(bs, xx, yy, x1, y1, x2, y2, in_out)
 in_out = False
 sub_row = bs.Cells(Rows.Count, 1).End(xlUp).Row
 For check_row = 2 To sub_row 
    x1 = bs.Cells(check_row, 1) - xx
    y1 = bs.Cells(check_row, 2) - yy
    x2 = bs.Cells(check_row, 3) - xx
    y2 = bs.Cells(check_row, 4) - yy
    If y1 * y2 > 0 Then GoTo bottom
    If x1 < 0 And x2 < 0 Then GoTo bottom
    If x1 + y1 * (x2 - x1) / (y1 - y2) >= 0 Then
        check_count = check_count + 1
    End If
 bottom:
 Next check_row
 If check_count Mod 2 = 1 Then in_out = True
 End Sub

 callで呼び出します
:bs:多角形座標が転記されているシート名
:xx:対象点X座標
:yy:対象点Y座標
:x1,y1,x2,y2:線分の端部座標
:check_count:交差回数(奇数ならば多角形内部にある)
:in_out:内部ならtrue 外部ならfalseを返します
多角形座標をシートに転記した場合で記述してあります。
メイン部分は代入が終わった後のif文以降ですので
必要に応じて書き換えてください

十分な長さを持つ線分と、多角形の各辺が交わる回数が
・奇数であれば多角形内
・偶数ならば多角形外
という定理を使用しています。

点1を原点として、各辺がX軸と交差するかどうかを全ての辺に対して判定し、
交差した回数を観察して判定させています。

多角形ソリッド図形の面積取得

 Sub solid_s_get(tmp, s)
 temp = tmp & " 0 0"
 s = 0
 a = Split(temp)
 If UBound(a) = 8 Then a(7) = a(1): a(8) = a(2)
    If UBound(a) >= 8 And a(0) = "sl" Then 
        
        x0 = Val(a(1))             '各座標を格納
        x1 = 0
        x2 = (a(3) - x0) / 1000
        x3 = (a(5) - x0) / 1000
        x4 = (a(7) - x0) / 1000
        y0 = Val(a(2))
        y1 = 0
        y2 = (a(4) - y0) / 1000
        y3 = (a(6) - y0) / 1000
        y4 = (a(8) - y0) / 1000
        la1 = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
        la2 = Sqr((x2 - x3) ^ 2 + (y2 - y3) ^ 2)
        la3 = Sqr((x3 - x4) ^ 2 + (y3 - y4) ^ 2)
        la4 = Sqr((x4 - x1) ^ 2 + (y4 - y1) ^ 2)
        la5 = Sqr((x3 - x1) ^ 2 + (y3 - y1) ^ 2)
        sh1 = (la1 + la2 + la5) / 2
        s1 = Sqr(sh1 * (sh1 - la1) * (sh1 - la2) * (sh1 - la5))
        sh2 = (la3 + la4 + la5) / 2
        s2 = Sqr(sh2 * (sh2 - la3) * (sh2 - la4) * (sh2 - la5))
        s = s1 + s2
            
    End If
 End Sub

※使用例

 tmp = jwc_temp_txt.readline
 s=0
 call solid_s_get(tmp, s)

tmpにはjwc_temp.txtから読み込んだ1行を代入する
sは戻り値を得るためのダミーとして0値を代入しておく

2点の角度を求める

call get_angle(x1, y1, x2, y2, angl)
 Sub get_angle(x1, y1, x2, y2, angl)
    '原点に対して2点間の角度を求める
    pai = 3.14159265358979
    xx = x2 - x1: yy = y2 - y1
    If yy = 0 Then
        If 0 < xx Then angl = 0
        If xx < 0 Then angl = pai
        GoTo endline
    End If
    If xx = 0 Then
        If 0 < yy Then angl = pai / 2
        If yy < 0 Then angl = -pai / 2
        GoTo endline
    End If
    angl = Atn(yy / xx)
    If xx < 0 Then angl = angl + pai
 endline:
 End Sub

:x1,y1,x2,y2:各点の各座標
:angl:点1を原点として点2がなす角度を反時計回りに計算して返します

点と線分の距離

 Sub get_distance_p_l(xx, yy, x1, y1, x2, y2, distance)
   'Call get_distance_p_l(xx, yy, x1, y1, x2, y2, distance)
    dx = (x2 - x1): dy = (y2 - y1)
    a = dx ^ 2 + dy ^ 2: b = dx * (x1 - xx) + dy * (y1 - yy)
    t = -b / a
    If t < 0 Then t = 0
    If t > 1 Then t = 1
    tx = x1 + dx * t: ty = y1 + dy * t
    distance = Sqr((xx - tx) ^ 2 + (yy - ty) ^ 2)
 End Sub

distanceに距離を返す

座標の回転

call rotate(x, y, angl, rx, ry)
Sub rotate(x, y, angl, rx, ry)
  rx = Cos(angl) * x - Sin(angl) * y
  ry = Sin(angl) * x + Cos(angl) * y
End Sub

角度はラジアン

文字列置換

変数としてコード内で使う場合

Temp = Replace( Text , "a" , "b" )

↑Textの中にあるaをbに置換してTempに格納

VBA_LenBで正確に数える

LenB(StrConv(対象文字列, vbFromUnicode))

全角と半角が混合された文字列では、Len関数及びLenB関数では正確な文字数がカウントできない。
そのためStrConvを挟んで一度変換する必要がある。

文字列から数値を抽出

Sub numerize(txt, t2)
  t1 = StrConv(txt, vbNarrow)
  t2 = ""
  For i = 1 To Len(t1)
    t3 = Mid(t1, i, 1)
    If t3 Like "[0-9]" Or t3 = "." or t3="-" Then t2 = t2 & t3
  Next
End Sub

或いは手続きとして

Function Numerize(ByVal txt As String)
  t1 = StrConv(txt, vbNarrow)
  t2 = ""
  For i = 1 To Len(t1)
    t3 = Mid(t1, i, 1)
    If t3 Like "[0-9]" Or t3 = "." Or t3 = "-" Then t2 = t2 & t3
  Next
  Numerize = t2
End Function

ワークシート系

フリガナを打つユーザー関数

以下のコードを標準モジュールに追加

Function getruby(a)
getruby = Application.getphonetic(a)
End Function

セルに「=ruby(セル番地)」として呼び出す。

クリップボードにコピー

Dim text As String
Dim CB As New DataObject
text = "コピー!"
With CB
    .SetText text
    .PutInClipboard
End With

印刷

    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

書式の変更を許可したシートプロテクト

  ActiveSheet.Protect AllowFormattingCells:=True

指定行にジャンプ

 ActiveWindow.ScrollRow = 10

入力規則

リストの内容を直接指定する場合

   With Sheets("シート名").Cells(y,x).Validation
         .Delete
         .Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=規則内容
         .ShowError = False
   End With

規則内容は「a,b,c,....」のように半角コンマで接続して記述すること
文字数上限255文字に注意

リストの内容にセル範囲を指定する場合

    With Sheets("シート名").Cells(y,x).Validation
        .Delete
        .Add Type:=xlValidateList, Operator:=xlBetween, Formula1:="=$y$x:$y$x"
    End With

新しいウィンドウを開く

 ActiveWorkbook.NewWindow

この一行だけ。

GoogleMapを開く

Sub open_google_map()
On Error GoTo endline
Dim objIE As Object, rowno As Integer
Set objIE = CreateObject("InternetExplorer.Application")
r = ActiveCell.Row
addrss = Cells(r, 6).Value
If addrss = "" Then addrss = Cells(r, 5).Value
With objIE
  'Google Map起動
  .Navigate "http://maps.google.co.jp/"
  .Visible = True
  'IE待機
  Do While .Busy = True
  DoEvents
  Loop
  '住所をテストボックスへ入力
  .Document.getElementById("q_d").Value = addrss
  '送信ボタンクリック
  .Document.forms(0).submit
End With
Set objIE = Nothing
End
endline:
MsgBox ("少し時間をあけてもう一度クリックしてください。IEの起動に失敗しました")
End Sub

あるいは

Q = chr(34)
GMurl = "http://maps.google.co.jp/?hl=ja&q="
Shell "explorer " & Q & GMurl & Q & "住所" & Q, vbNormalFocus

デフォルトブラウザで開く、はず。
FireFoxのみ動作確認済。
これを応用すればエクセルブックから何でも開ける、のかな。
関連付けされているファイル形式なら。

セルの値が計算式か否か

 Cells(44, 6).Formula

上記でセルの値ではなく、セルに書かれた内容を取得できる。

これを使って

 if left(Cells(44, 6).Formula,1) = "=" then

と書けばそのセルには計算式が入っているという算段。

起動時に別のエクセルで開かせる

「ツール」>「オプション」>「全般」>「ほかのアプリケーションを無視する」

セルの色を全て削除

 Cells.Interior.ColorIndex = xlNone

使用済みセルの最終行を取得する

1.シート全体の最終行を取得する場合

 last_row = ss.UsedRange.Rows.Count

2.特定の列での最終行を取得する場合

 last_row = Cells(Rows.Count, 1).End(xlUp).Row

※ここでは1列目を参照しています。

 2列目を参照するためには

 last_row = Cells(Rows.Count, 2).End(xlUp).Row

でOK。

使用済みセルの最終列を取得する

 For b = 255 To 1 Step -1
    Cells(a, b).Select
    If Cells(a, b).Value <> "" Then Exit For
 Next b

a:検索する行番号
b:最終列を返します

  • エクセルは列数が255までしか使用できません。
  • 短い上に使用頻度が低いのでスクリプト内に埋め込む場合で記述してあります。

外部ブック上のセルを参照

 Sub get_from_another_book(vl)
    'ファイルを開くダイアログ
    tmp = Application.GetOpenFilename("エクセルブック(*.xls),*.xls")
    If tmp = False Then End
    'targetfileに開いたファイルをセット
    Set targetfile = Application.Workbooks.Open(tmp)
    'ここに処理内容を記述(下行はサンプル)
    vl = targetfile.Worksheets(1).Cells(1, 1).Value
    
    'アラートを出さずに開いたファイルを閉じる
    targetfile.Close SaveChanges:=False
 End Sub

オートフィルタによる擬似インクリメンタルサーチ

オートフィルタが掛けられている状態で使用可。
下記の例では検索用キーワード入力セルが上から3番目にあり、オートフィルタは4行目から開始している条件での設定。

'※プロシージャの記入は標準モジュールではなくワークシートに''

Private Sub Worksheet_Change(ByVal Target As Range)
  x = Target.Column
  y = Target.Row
  '検索用キーワード入力セルの行(オートフィルタ用タイトル行のひとつ上とかが便利。どこでも構わない。)
  Search_row=3
  'オートフィルタが設定されている最初の列-1列。(A列から開始する場合はこの値を「0」に)
  Search_clm=3
  tmp = Cells(y, x)
  '範囲選択で消去した場合のエラー回避
  On Error Resume Next
  If y = Search_row Then
    '空白にされたら絞り込み解除
    If tmp = "" Then
      Selection.AutoFilter Field:=(x - Search_clm)
    'キーワードをオートフィルタで絞り込み
    Else
      Selection.AutoFilter Field:=(x - Search_clm), Criteria1:="=*" & tmp & "*", Operator:=xlAnd
    End If
  End If
  'エラー回避終了
  On Error GoTo 0
End Sub

まれにエクセルのマクロ実行やオートフィルタにタイムロスするケースがあるが、通常時では見事に高速。
入力と同時に絞り込まれる感覚が快適。

セル範囲指定置換

セル上で置換する場合

 Range("a1:g31").Replace What:="g", Replacement:="w"

イベント系

保存時

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
End Sub

ファイルを開いた時

Private Sub Workbook_Open()
 '
End Sub

シートがアクティブになったとき

Private Sub Worksheet_Activate()
 '
End Sub

シートが非アクティブになったとき

Private Sub Worksheet_Deactivate()
  '
End Sub

保存時

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
End Sub

右クリック時

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  x = Target.Column
  y = Target.Row
  tmp = Cells(y,x)
End sub

セルの内容が変更されたとき

Private Sub Worksheet_Change(ByVal Target As Range)
  x = Target.Column
  y = Target.Row
  tmp = Cells(y,x)
End Sub

選択セルが変更されたとき

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  x = Target.Column
  y = Target.Row
  tmp = Cells(y,x)
End Sub

ダブルクリック時

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  x = Target.Column
  y = Target.Row
  tmp = Cells(y,x)
End Sub

その他

ファイルオープン時にマクロを実行する

 Private Sub Workbook_Open()
   プロシージャ名
 End Sub

ワークブックに記述

ファイルを保存せずにエクセルを終了

 ThisWorkbook.Saved = True
 Application.Quit

ステータスバーにメッセージを表示する

 '///////////////////////////////////////////////////////////////////////////
 Application.StatusBar = "メッセージ"
 '///////////////////////////////////////////////////////////////////////////

Applicaton.ScreenUpdating=False でも有効

カラーインデックス一覧

http://hinoado.com/tw/img/xls_colorindex.png
セル範囲の色を変える時は

    Range("F14:J48").Interior.ColorIndex = 24
又は
    Range(cells(1,1),cells(3,3)).Interior.ColorIndex = 24

で、セルの色を変える時は

    Range("F14").Interior.ColorIndex = 24

行を変える時は

    rows(n).Interior.ColorIndex = 24

列を変える時は

    columns(n).Interior.ColorIndex = 24

処理時間を測る

  T = Timer
  'ここに処理を記述
  MsgBox( Timer - T )

タブ文字

chr(9)

セル内改行

chr(10)

ダブルクォーテーション「"」

chr(34)

改行コード

 & Chr(13) & Chr(10) &

エラーを無視させる

 On Error Resume Next

で全てのエラーを無視するようになる。
これを復帰させるのは

 On Error GoTo 0

これで通常モードに。

フォントサイズとドット数の関係式

フォントが12ptの場合
12x96dpi/72=16pixel

フォントサイズと画面ドット数の関係一覧

フォントサイズ96dpi120dpi
6pt810
7pt911
8pt1013
9pt1215
10pt1316
11pt1418
12pt1620
13pt1721
14pt1823
15pt2025
16pt2126
17pt2228
18pt2430
19pt2531
20pt2633
21pt2835
22pt2936
23pt3038
24pt3240
25pt3341
26pt3443
27pt3645
28pt3746
29pt3848
30pt4050
31pt4151
32pt4253

エクセルユーザー名

 Application.UserName

グローバル変数

 Public a

subプロシージャの外に記述

ファイル参照変換機能

JWWのファイル変換参照機能をエクセルで管理するプロシージャ

Sub ファイル参照変換機能()
  Dim Last_Row
  Dim Tmp_Sheet As Worksheet
  Set Tmp_Sheet = Sheets("シート名")
  'A列で使用されている最終行を取得
  Last_Row = Cells(Rows.Count, 1).End(xlUp).Row
  '出力するファイルの準備
  Dim File_Sytem
  Dim OutputText
  Set File_Sytem = CreateObject("Scripting.FileSystemObject")
  '出力するファイルを定義(下記の例ではこのエクセルブックと同じフォルダに出力)
  Set OutputText = File_Sytem.CreateTextFile(ThisWorkbook.Path & "\ファイル名.txt", True)
  'シートからファイル参照変換機能定義ファイルを作成
  For i = 1 To Last_Row
    '空欄は無視
    If Tmp_Sheet.Cells(i, 1) <> "" Then
    
      'A列に参照文字、B列に変換後文字の例
      参照文字 = Tmp_Sheet.Cells(i, 1)
      変換文字 = Tmp_Sheet.Cells(i, 2)
      
      '変換文字が空欄の場合はハイフンを代入(空欄のままでは参照文字列がそのまま表示される)
      If 変換文字 = "" Then 変換文字 = "-"
      OutputText.writeline ("%%" & 参照文字 & Chr(9) & 変換文字)
    
    End If
  Next
  'ファイルを閉じる
  OutputText.Close
End Sub

ウィンドウ枠の固定と解除

固定

  • アクティブなセルの左上で固定されます
ActiveWindow.FreezePanes = True

解除

ActiveWindow.FreezePanes = False

VBAからVBSを実行する

    Shell "WScript.exe ""「ファイル名」"""

sendkeys

{ENTER}Enter
{ESCAPE},{ESC}Esc
{TAB}Tab
{INSERT}Insert
{DELETE},{DEL}Delete
{BACKSPACE},{BS},{BKSP}Backspace
{LEFT}
{RIGHT}
{UP}
{DOWN}
{PGUP}PageUp
{PGDN}PageDown
{HOME}Home
{END}End
{SCROLLLOCK}ScrollLock
{BREAK}Pause
{NUMLOCK}NumLock
{CAPSLOCK}CapsLock
{F1}~{F12}F1~F12
+Shift
^Ctrl
%Alt

%Sで「Alt」と「S」の同時押し
%(AB)で「Alt」と「A」と「B」の同時押し
{UP}2で上矢印キー2回押し
hogehogeで文字列

セルに書き込まれたソリッド色コードでセルを塗る(Excel2007以降)

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim tmp As Long
  x = Target.Column
  y = Target.Row
  If IsNumeric(Cells(y, x)) Then
    If Val(Cells(y, x)) < 16777216 Then
      Cells(y, x).Interior.Color = Val(Cells(y, x))
    End If
  End If
End Sub