home HinoADO
Menu

  • 追加された行はこの色です。
  • 削除された行はこの色です。
#author("2017-11-26T22:50:26+09:00","","")
JW_CADで外部変形等を作成する際にエクセルで用いるプロシージャ集の備忘録
#contents
*jwc_temp.txt解析 [#w75daa08]
**外変か編集モードかを判断する [#l0aa7ce0]
  
 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に記述する。

**アクティブスケール取得 [#g90b7a19]
  
  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


**作業ファイルのフォルダパスを取得 [#i9d86899]
  
 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が指定された場合) [#y67511ab]
  
  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


**作図基点を取得 [#yaaea33b]
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


**アクティブグループを取得 [#y4938993]
  
 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内から線色定義を探す [#jcb7ed68]
  
  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内から線種定義を探す [#db69c559]
  
  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内からレイヤグループ定義を探す [#w9488fa4]
  
  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内からレイヤ定義を探す [#ya9056fc]
  
  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


**文字種からサイズを取得 [#v127d4fc]
  
  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


*ファイル処理 [#wcc14502]
**外部テキストファイルの参照 [#da03fda1]
  
  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


**テキストファイルの書き出し [#u8268813]
  
  Dim fs
  Dim jwtmp
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set jwtmp = fs.CreateTextFile("jwc_temp.txt", True)
     jwtmp.writeline("書き出す内容")
  jwtmp.close


**ファイルの有無をチェック [#f79cb8da]
  
 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


**ファイルリスト取得 [#z70bd37d]
  
 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

**フォルダの有無をチェック [#m056965a]
  
   If Dir("フォルダのフルパス", vbDirectory ) <> "" Then
     MsgBox "Exist"
   Else
     MsgBox "not Exist"
   End If


**フォルダを作成する [#l8eba9a5]
CHDirでカレントフォルダを設定可。フルパス表記も可。
  
 MkDir "フォルダ名"


**フォルダを開く [#tcc49c0c]
  
 Shell "explorer " & フォルダ名, vbNormalFocus

**ファイルを開く [#f64c3d30]
  
 Shell "explorer " & ファイル名, vbNormalFocus


**ファイルをコピー [#a06bc68f]
  
 FileCopy ファイル名


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


**バックアップを作成 [#c07695ee]
  
 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指定で出力する [#c29a296f]
  
   'オブジェクトを作成
     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


*関数 [#a7a5c87b]
**Format関数 [#d57ae1cf]
  
  Format(5459.4,"##,##0.00")

さらに詳細は[[こちら>http://members.jcom.home.ne.jp/rex-uchida/vba051.htm]]

|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)に変換 [#jc809e25]

  
 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


**線分の長さ [#h4d3d0e2]
  
   lngth = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ 0.5


**線分と任意の点に対する垂線の交点 [#zb6ed987]
  
 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


**バブルソート [#md536874]
値の小さい方が若い番号に格納されます
  
   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


**点が多角形の内部にあるか [#m3dda53b]
  
  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軸と交差するかどうかを全ての辺に対して判定し、
交差した回数を観察して判定させています。

**多角形ソリッド図形の面積取得 [#ne1e8407]
  
  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点の角度を求める [#w66b1ec1]
  
 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がなす角度を反時計回りに計算して返します
**点と線分の距離 [#k50e3e63]
  
  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に距離を返す

**座標の回転 [#j546b411]
  
 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

角度はラジアン

**文字列置換 [#x7e518c4]
変数としてコード内で使う場合
  
 Temp = Replace( Text , "a" , "b" )

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

**VBA_LenBで正確に数える [#na7468cd]
  
 LenB(StrConv(対象文字列, vbFromUnicode))

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

**文字列から数値を抽出 [#qf82d9fe]
  
 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

*ワークシート系 [#h56311ea]
**フリガナを打つユーザー関数 [#zaa18684]
以下のコードを標準モジュールに追加
  
 Function getruby(a)
 getruby = Application.getphonetic(a)
 End Function

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

**クリップボードにコピー [#e5e5d27d]
  
 Dim text As String
 Dim CB As New DataObject
 text = "コピー!"
 With CB
     .SetText text
     .PutInClipboard
 End With


**印刷 [#uba2de96]
  
     ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True


**書式の変更を許可したシートプロテクト [#ba0bd90d]
  
   ActiveSheet.Protect AllowFormattingCells:=True


**指定行にジャンプ [#z029caa1]
  
  ActiveWindow.ScrollRow = 10


**入力規則 [#j45d94a7]
リストの内容を直接指定する場合
  
    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


**新しいウィンドウを開く [#y44978d4]
  
  ActiveWorkbook.NewWindow

この一行だけ。

**GoogleMapを開く [#m3a81d1e]
  
 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のみ動作確認済。
これを応用すればエクセルブックから何でも開ける、のかな。
関連付けされているファイル形式なら。

**セルの値が計算式か否か [#j67307ba]
  
  Cells(44, 6).Formula

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

これを使って
  
  if left(Cells(44, 6).Formula,1) = "=" then

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

**起動時に別のエクセルで開かせる [#ma8d9754]
「ツール」>「オプション」>「全般」>「ほかのアプリケーションを無視する」

**セルの色を全て削除 [#qba60be6]
  
  Cells.Interior.ColorIndex = xlNone


**使用済みセルの最終行を取得する [#w173f94b]

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。

**使用済みセルの最終列を取得する [#d45785b7]
  
  For b = 255 To 1 Step -1
     Cells(a, b).Select
     If Cells(a, b).Value <> "" Then Exit For
  Next b

a:検索する行番号
b:最終列を返します
-エクセルは列数が255までしか使用できません。
-短い上に使用頻度が低いのでスクリプト内に埋め込む場合で記述してあります。

**外部ブック上のセルを参照 [#fc36e885]
  
  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


**オートフィルタによる擬似インクリメンタルサーチ [#f6f0223e]
オートフィルタが掛けられている状態で使用可。
下記の例では検索用キーワード入力セルが上から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

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

**セル範囲指定置換 [#zd9b6ca7]
セル上で置換する場合
  
  Range("a1:g31").Replace What:="g", Replacement:="w"


*イベント系 [#i7dee937]
**保存時 [#t18a42cf]
  
 Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 
 End Sub


**ファイルを開いた時 [#s7ba40cc]
  
 Private Sub Workbook_Open()
  '
 End Sub


**シートがアクティブになったとき [#c3d036c8]
  
 Private Sub Worksheet_Activate()
  '
 End Sub


**シートが非アクティブになったとき [#s1bcbe7b]
  
 Private Sub Worksheet_Deactivate()
   '
 End Sub

**保存時 [#m9e52641]
  
 Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 
 End Sub


**右クリック時 [#q4a2cf8d]
  
 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   x = Target.Column
   y = Target.Row
   tmp = Cells(y,x)
 End sub

**セルの内容が変更されたとき [#h85f18dc]
  
 Private Sub Worksheet_Change(ByVal Target As Range)
   x = Target.Column
   y = Target.Row
   tmp = Cells(y,x)
 End Sub

**選択セルが変更されたとき [#la941bc1]
  
 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   x = Target.Column
   y = Target.Row
   tmp = Cells(y,x)
 End Sub

**ダブルクリック時 [#z01d2657]
  
 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   x = Target.Column
   y = Target.Row
   tmp = Cells(y,x)
 End Sub


*その他 [#m1f66f05]
**ファイルオープン時にマクロを実行する [#ge8d7803]
  
  Private Sub Workbook_Open()
    プロシージャ名
  End Sub

ワークブックに記述

**ファイルを保存せずにエクセルを終了 [#v9c0a17b]
  
  ThisWorkbook.Saved = True
  Application.Quit


**ステータスバーにメッセージを表示する [#m47d9b2a]
  
  '///////////////////////////////////////////////////////////////////////////
  Application.StatusBar = "メッセージ"
  '///////////////////////////////////////////////////////////////////////////

Applicaton.ScreenUpdating=False でも有効

**カラーインデックス一覧 [#zb5b796f]
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


**処理時間を測る [#b23d8c29]
  
   T = Timer
   'ここに処理を記述
   MsgBox( Timer - T )


**タブ文字 [#lc6db1bd]
  
 chr(9)


**セル内改行 [#r5ad83f4]
  
 chr(10)


**ダブルクォーテーション「"」 [#cea08ecf]
  
 chr(34)

**改行コード [#i3257262]
  
  & Chr(13) & Chr(10) &



**エラーを無視させる [#f25053d6]
  
  On Error Resume Next

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

これで通常モードに。

**フォントサイズとドット数の関係式 [#r4c5dca9]
フォントが12ptの場合
12x96dpi/72=16pixel

フォントサイズと画面ドット数の関係一覧
|フォントサイズ|96dpi|120dpi|
|6pt|8|10|
|7pt|9|11|
|8pt|10|13|
|9pt|12|15|
|10pt|13|16|
|11pt|14|18|
|12pt|16|20|
|13pt|17|21|
|14pt|18|23|
|15pt|20|25|
|16pt|21|26|
|17pt|22|28|
|18pt|24|30|
|19pt|25|31|
|20pt|26|33|
|21pt|28|35|
|22pt|29|36|
|23pt|30|38|
|24pt|32|40|
|25pt|33|41|
|26pt|34|43|
|27pt|36|45|
|28pt|37|46|
|29pt|38|48|
|30pt|40|50|
|31pt|41|51|
|32pt|42|53|

**エクセルユーザー名 [#p3499359]
  
  Application.UserName


**グローバル変数 [#w3db02bf]
  
  Public a

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

**ファイル参照変換機能 [#w9ae2087]
JWWの[[ファイル変換参照機能>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


**ウィンドウ枠の固定と解除 [#xbe64e12]
*固定 [#gc93d877]
--アクティブなセルの左上で固定されます
  
 ActiveWindow.FreezePanes = True


*解除 [#r1c1d685]
  
 ActiveWindow.FreezePanes = False


**VBAからVBSを実行する [#ac00e711]
  
     Shell "WScript.exe ""「ファイル名」"""


**sendkeys [#u0922470]
|{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以降) [#xe172247]
  
 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