- 追加された行はこの色です。
- 削除された行はこの色です。
- Jww/etc/外変用エクセルVBAコード へ行く。
#author("2017-11-26T22:51:43+09:00","","") #author("2017-11-26T22:53:24+09:00","","") JW_CADで外部変形等を作成する際にエクセルで用いるプロシージャ集の備忘録 #contents *jwc_temp.txt解析 [#oed31dcb] **外変か編集モードかを判断する [#gd3cef4c] *jwc_temp.txt解析 [#j80abeb0] **外変か編集モードかを判断する [#z2fd6141] 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に記述する。 **アクティブスケール取得 [#fbee38f7] **アクティブスケール取得 [#mb86cbbc] 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 **作業ファイルのフォルダパスを取得 [#t667a5c4] **作業ファイルのフォルダパスを取得 [#p51e8c9a] 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が指定された場合) [#k39ce5d8] **ファイル名を含むフルパスを取得(#hfが指定された場合) [#v075301b] 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 **作図基点を取得 [#u9a153eb] **作図基点を取得 [#a6aa71c5] 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 **アクティブグループを取得 [#c2984736] **アクティブグループを取得 [#d3bdaad8] 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内から線色定義を探す [#g3e9eb1d] **jwc_temp.txt内から線色定義を探す [#b711fd17] 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内から線種定義を探す [#dd299465] **jwc_temp.txt内から線種定義を探す [#le1ae42f] 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内からレイヤグループ定義を探す [#ocdc0327] **jwc_temp.txt内からレイヤグループ定義を探す [#cdf1cf02] 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内からレイヤ定義を探す [#ged69156] **jwc_temp.txt内からレイヤ定義を探す [#i8d1f2d7] 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 **文字種からサイズを取得 [#taa30189] **文字種からサイズを取得 [#p1a72aa3] 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 *ファイル処理 [#obff7849] **外部テキストファイルの参照 [#y1fd62f9] *ファイル処理 [#t70f480a] **外部テキストファイルの参照 [#bf52bdf5] 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 **テキストファイルの書き出し [#b05102cc] **テキストファイルの書き出し [#ga98f567] Dim fs Dim jwtmp Set fs = CreateObject("Scripting.FileSystemObject") Set jwtmp = fs.CreateTextFile("jwc_temp.txt", True) jwtmp.writeline("書き出す内容") jwtmp.close **ファイルの有無をチェック [#j01b99db] **ファイルの有無をチェック [#abf21c1d] 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 **ファイルリスト取得 [#i1a612c8] **ファイルリスト取得 [#hc684296] 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 **フォルダの有無をチェック [#oecb55e0] **フォルダの有無をチェック [#c4e8055f] If Dir("フォルダのフルパス", vbDirectory ) <> "" Then MsgBox "Exist" Else MsgBox "not Exist" End If **フォルダを作成する [#ybb051f2] **フォルダを作成する [#cb48d5f9] CHDirでカレントフォルダを設定可。フルパス表記も可。 MkDir "フォルダ名" **フォルダを開く [#xe96af98] **フォルダを開く [#d6266870] Shell "explorer " & フォルダ名, vbNormalFocus **ファイルを開く [#b25904ae] **ファイルを開く [#kc054d55] Shell "explorer " & ファイル名, vbNormalFocus **ファイルをコピー [#l604e318] **ファイルをコピー [#r05fead1] FileCopy ファイル名 ファイル名を変更してコピーする場合は FileCopy ファイル名 , 変更後のファイル名 **バックアップを作成 [#d7fe0614] **バックアップを作成 [#qfcb5d92] 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指定で出力する [#r4705b80] **テキストファイルを文字コードUTF-8N指定で出力する [#rb878447] 'オブジェクトを作成 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 *関数 [#h796c128] **Format関数 [#m9641a99] *関数 [#h836259f] **Format関数 [#u198fb3f] 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)に変換 [#uc21e011] **ソリッド色コードをRGB（Dec)に変換 [#d4321024] 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 **線分の長さ [#rf44e20e] **線分の長さ [#l6d7d0fd] lngth = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ 0.5 **線分と任意の点に対する垂線の交点 [#te86702d] **線分と任意の点に対する垂線の交点 [#zf0a3b70] 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 **バブルソート [#w59993ac] **バブルソート [#nb2b6e05] 値の小さい方が若い番号に格納されます 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 **点が多角形の内部にあるか [#r5d5c4a9] **点が多角形の内部にあるか [#m561845e] 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軸と交差するかどうかを全ての辺に対して判定し、 交差した回数を観察して判定させています。 **多角形ソリッド図形の面積取得 [#e7b618f2] **多角形ソリッド図形の面積取得 [#tf1113a4] 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点の角度を求める [#l7068731] **2点の角度を求める [#y18affb4] 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がなす角度を反時計回りに計算して返します **点と線分の距離 [#bc516086] **点と線分の距離 [#h806f9ce] 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に距離を返す **座標の回転 [#ub01ff0c] **座標の回転 [#b850154e] 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 角度はラジアン **文字列置換 [#df045533] **文字列置換 [#i63a3e78] 変数としてコード内で使う場合 Temp = Replace( Text , "a" , "b" ) ↑Textの中にあるaをbに置換してTempに格納 **VBA_LenBで正確に数える [#m738e7aa] **VBA_LenBで正確に数える [#ye69bc12] LenB(StrConv(対象文字列, vbFromUnicode)) 全角と半角が混合された文字列では、Len関数及びLenB関数では正確な文字数がカウントできない。 そのためStrConvを挟んで一度変換する必要がある。 **文字列から数値を抽出 [#z2eabcad] **文字列から数値を抽出 [#ra0f861b] 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 *ワークシート系 [#v4bbe9ee] **フリガナを打つユーザー関数 [#l5a9b04f] *ワークシート系 [#lce4b665] **フリガナを打つユーザー関数 [#d2679d0d] 以下のコードを標準モジュールに追加 Function getruby(a) getruby = Application.getphonetic(a) End Function セルに「=ruby(セル番地)」として呼び出す。 **クリップボードにコピー [#w911b725] **クリップボードにコピー [#cc8c9684] Dim text As String Dim CB As New DataObject text = "コピー！" With CB .SetText text .PutInClipboard End With **印刷 [#k78c5416] **印刷 [#a3c4d415] ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True **書式の変更を許可したシートプロテクト [#e742ad57] **書式の変更を許可したシートプロテクト [#b13d5d18] ActiveSheet.Protect AllowFormattingCells:=True **指定行にジャンプ [#n74b0487] **指定行にジャンプ [#z3e74383] ActiveWindow.ScrollRow = 10 **入力規則 [#xff83adf] **入力規則 [#q4020f59] リストの内容を直接指定する場合 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 **新しいウィンドウを開く [#p8a5cd1c] **新しいウィンドウを開く [#x61714e4] ActiveWorkbook.NewWindow この一行だけ。 **GoogleMapを開く [#l41fbc86] **GoogleMapを開く [#n97c2af4] 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のみ動作確認済。 これを応用すればエクセルブックから何でも開ける、のかな。 関連付けされているファイル形式なら。 **セルの値が計算式か否か [#tfa240aa] **セルの値が計算式か否か [#p9bf692a] Cells(44, 6).Formula 上記でセルの値ではなく、セルに書かれた内容を取得できる。 これを使って if left(Cells(44, 6).Formula,1) = "=" then と書けばそのセルには計算式が入っているという算段。 **起動時に別のエクセルで開かせる [#g6b4a769] **起動時に別のエクセルで開かせる [#r1e095b8] 「ツール」＞「オプション」＞「全般」＞「ほかのアプリケーションを無視する」 **セルの色を全て削除 [#m3005858] **セルの色を全て削除 [#n6bc07e1] Cells.Interior.ColorIndex = xlNone **使用済みセルの最終行を取得する [#yfc6e773] **使用済みセルの最終行を取得する [#x5ad3214] 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。 **使用済みセルの最終列を取得する [#l75566d1] **使用済みセルの最終列を取得する [#y3ebb41c] For b = 255 To 1 Step -1 Cells(a, b).Select If Cells(a, b).Value <> "" Then Exit For Next b a:検索する行番号 b:最終列を返します -エクセルは列数が255までしか使用できません。 -短い上に使用頻度が低いのでスクリプト内に埋め込む場合で記述してあります。 **外部ブック上のセルを参照 [#ea9e86b5] **外部ブック上のセルを参照 [#ld34b4a7] 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 **オートフィルタによる擬似インクリメンタルサーチ [#dd86d033] **オートフィルタによる擬似インクリメンタルサーチ [#gf789080] オートフィルタが掛けられている状態で使用可。 下記の例では検索用キーワード入力セルが上から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 まれにエクセルのマクロ実行やオートフィルタにタイムロスするケースがあるが、通常時では見事に高速。 入力と同時に絞り込まれる感覚が快適。 **セル範囲指定置換 [#sc8d20d4] **セル範囲指定置換 [#u3f6d2f2] セル上で置換する場合 Range("a1:g31").Replace What:="g", Replacement:="w" *イベント系 [#tf95e47a] **保存時 [#s13383d7] *イベント系 [#ca8d76eb] **保存時 [#n2eefd43] Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) End Sub **ファイルを開いた時 [#q709fed0] **ファイルを開いた時 [#ob0fd562] Private Sub Workbook_Open() ' End Sub **シートがアクティブになったとき [#i86b42dc] **シートがアクティブになったとき [#ife467d5] Private Sub Worksheet_Activate() ' End Sub **シートが非アクティブになったとき [#qedc0974] **シートが非アクティブになったとき [#te12a0a5] Private Sub Worksheet_Deactivate() ' End Sub **保存時 [#n94754f0] **保存時 [#bbaf7cba] Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) End Sub **右クリック時 [#pf82f727] **右クリック時 [#k735febc] Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) x = Target.Column y = Target.Row tmp = Cells(y,x) End sub **セルの内容が変更されたとき [#l4f394bf] **セルの内容が変更されたとき [#i2c47fb0] Private Sub Worksheet_Change(ByVal Target As Range) x = Target.Column y = Target.Row tmp = Cells(y,x) End Sub **選択セルが変更されたとき [#d9599e9a] **選択セルが変更されたとき [#k3f2bba2] Private Sub Worksheet_SelectionChange(ByVal Target As Range) x = Target.Column y = Target.Row tmp = Cells(y,x) End Sub **ダブルクリック時 [#a0ef6323] **ダブルクリック時 [#pdc8930c] Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) x = Target.Column y = Target.Row tmp = Cells(y,x) End Sub *その他 [#c4cac480] **ファイルオープン時にマクロを実行する [#rd50838b] *その他 [#e9d9dde8] **ファイルオープン時にマクロを実行する [#i131b875] Private Sub Workbook_Open() プロシージャ名 End Sub ワークブックに記述 **ファイルを保存せずにエクセルを終了 [#l0ec8e76] **ファイルを保存せずにエクセルを終了 [#sb132f3c] ThisWorkbook.Saved = True Application.Quit **ステータスバーにメッセージを表示する [#z03b8c12] **ステータスバーにメッセージを表示する [#udc481bc] '/////////////////////////////////////////////////////////////////////////// Application.StatusBar = "メッセージ" '/////////////////////////////////////////////////////////////////////////// Applicaton.ScreenUpdating=False でも有効 **カラーインデックス一覧 [#i2f9e386] **カラーインデックス一覧 [#p4748d2a] 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 **処理時間を測る [#m8ec3dc3] **処理時間を測る [#nf136201] T = Timer 'ここに処理を記述 MsgBox( Timer - T ) **タブ文字 [#pb993635] **タブ文字 [#l2a0269f] chr(9) **セル内改行 [#gddeefb7] **セル内改行 [#td00a4a6] chr(10) **ダブルクォーテーション「"」 [#y3b8972c] **ダブルクォーテーション「"」 [#t41683fe] chr(34) **改行コード [#ee1db9cf] **改行コード [#n26c73dd] & Chr(13) & Chr(10) & **エラーを無視させる [#l842cf60] **エラーを無視させる [#ebaad488] On Error Resume Next で全てのエラーを無視するようになる。 これを復帰させるのは On Error GoTo 0 これで通常モードに。 **フォントサイズとドット数の関係式 [#v5de5ef1] **フォントサイズとドット数の関係式 [#pa55c0ec] フォントが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| **エクセルユーザー名 [#w63d6d79] **エクセルユーザー名 [#t36e2b2c] Application.UserName **グローバル変数 [#ef2e81e8] **グローバル変数 [#vf15a84f] Public a と'''subプロシージャの外'''に記述 **ファイル参照変換機能 [#gfb004f0] **ファイル参照変換機能 [#w8e33981] 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 **ウィンドウ枠の固定と解除 [#iac10293] *固定 [#w10ea34e] **ウィンドウ枠の固定と解除 [#s940a130] *固定 [#x67f4a79] --アクティブなセルの左上で固定されます ActiveWindow.FreezePanes = True *解除 [#d830e8ac] *解除 [#d68cb341] ActiveWindow.FreezePanes = False **VBAからVBSを実行する [#q88a6321] **VBAからVBSを実行する [#ld6c8f6a] Shell "WScript.exe ""「ファイル名」""" **sendkeys [#jeb7b3e7] **sendkeys [#m9775f7f] |{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以降) [#l0194522] **セルに書き込まれたソリッド色コードでセルを塗る(Excel2007以降) [#n20471d6] 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