• バックアップ一覧
• 差分 を表示
• 現在との差分 を表示
• ソース を表示
• Jww/etc/外変用エクセルVBAコード へ行く。
  • 1 (2017-11-26 (日) 22:50:26)

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")

さらに詳細はこちら

ソリッド色コードを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

  'オートフィルタが設定されている最初の列－１列。(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　でも有効

カラーインデックス一覧 †

セル範囲の色を変える時は

 
    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

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

エクセルユーザー名 †

 
 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 †

%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