Excel/Excel VBAの最近のブログ記事

先日ツイッターでアンケートを採りました。「スマホで使っている日本語入力アプリはなんですか」というものです。選択肢は、

  1. Google日本語入力
  2. Simeji
  3. ATOK
  4. その他

です。思いの外Simejiのシェアが高かったので、何か野良辞書を作るときにSimeji形式のものは欠かせないだろうという印象を受けました。

ATOKやMS-IME、Google日本語入力は細かいところを除き、基本的に「よみ(TAB)単語」形式です。

読み1 (TAB区切り) 単語1 (改行)
読み2 (TAB区切り) 単語2 (改行)



読みX (TAB区切り) 単語X (改行)

ところがSimeji形式は改行無しの1行で「ヘッダー1:"単語1,"単語2",・・・,ヘッダー2:"読み1","読み2",・・・フッター」というちょっとというか相当変わったものです。

{"EN_KEY":[],"EN_VALUE":[],"JAJP_VALUE":["単語1","単語2",・・・"単語X"],"JAJP_KEY":["読み1","読み2",・・・"読みX"]}

そういうわけで、ある程度単語数が多い場合は何かしら変換プログラムを作らないと大変だと分かりました。

 

まず、シート"Simeji"に、ヘッダー1、ヘッダー2、フッターをそれぞれセルに格納しておきます。コード内に書いてもいいんですが、長いしダブルクォーテーションが多いので間違えないように。

別のシート"Dic"に辞書を貼り付けます。ここら辺はとりあえず手動です。また、コメント行なども手動で削除しておきます。

コードの流れとしては、

とりあえず上書き保存→最終行を調べる→ヘッダー1を格納→単語列を""で囲って格納(for next)→ヘッダー2を格納→読み列を""で囲って格納(for next)→フッターを格納→新規シートを作ってA1セルに書き込む

という感じ。最初に上書き保存するのは最終行の誤認識を防ぐため。新規シートは日付と時刻でシート名を作ります。A1セルに入れてるのも手抜きで。手動でテキストエディタにコピペしてUTF-8/LFでファイル名"simeji_user_dic.txt"で保存して完了です。

コードです。ちょっと適当です。

Sub Dic2Simeji()

    Dim StrDic As String
    Dim StrSimejiHeader1 As String
    Dim StrSimejiHeader2 As String
    Dim StrSimejiFooter As String
    Dim NewShtName As String
    Dim DblRowCount As Double

    ' /// 最初に上書き保存する ///
    ActiveWorkbook.Save
    
    ' /// 最終行を取得 ///
    DblRowCount = Worksheets("Dic").Cells.SpecialCells(xlLastCell).Row

    StrSimejiHeader1 = Worksheets("Simeji").Cells(2, 2).Text
    StrSimejiHeader2 = Worksheets("Simeji").Cells(3, 2).Text
    StrSimejiFooter = Worksheets("Simeji").Cells(4, 2).Text

    StrDic = ""

    ' /// ヘッダー1を格納 ///
    StrDic = StrSimejiHeader1

    ' /// 単語列を格納 ///
    For n = 1 To DblRowCount - 1
        StrDic = StrDic & Chr(34) & Worksheets("Dic").Cells(n, 2).Text & Chr(34) & ","
    Next n
    StrDic = StrDic & Chr(34) & Worksheets("Dic").Cells(DblRowCount, 2).Text & Chr(34)

    ' /// ヘッダー2を格納 ///
    StrDic = StrDic & StrSimejiHeader2

    ' /// 読み列を格納 ///
    For n = 1 To DblRowCount - 1
        StrDic = StrDic & Chr(34) & Worksheets("Dic").Cells(n, 1).Text & Chr(34) & ","
    Next n
    StrDic = StrDic & Chr(34) & Worksheets("Dic").Cells(DblRowCount, 1).Text & Chr(34)

    ' /// フッターを格納 ///
    StrDic = StrDic & StrSimejiFooter

    ' /// Simeji,Dic以外の古いシートを削除 ///
    If Worksheets.Count > 2 Then
        For n = Worksheets.Count To 3 Step -1
            Application.DisplayAlerts = False
            Worksheets(n).Delete
            Application.DisplayAlerts = True
        Next n
    End If

    ' /// 新しいシートを作成(シート名は日付と時刻から生成)///
    NewShtName = CStr(Year(Date) & Month(Date) & Day(Date) & Hour(Time) & Minute(Time) & Second(Time))
    With Worksheets.Add(after:=Worksheets(Worksheets.Count))
        .Name = NewShtName
    End With

    ' /// 作成したシートのA1セルにStrDicを書き込む
    ActiveSheet.Cells(1, 1).Value = StrDic

    MsgBox "A1セルをコピーして任意のテキストエディタに貼り付けてください。" _
            & vbCrLf & "エンコード:UTF-8, 改行:LF で保存する。"
    
End Sub
Sub OpenAnyFolder()
' ◆◆ いろいろなフォルダを開く ◆◆
    Dim strPath As String
    
    '***既定のファイルの場所(オプション>保存で設定)
    'strPath = Application.DefaultFilePath
    
    '***アドインフォルダ C:\Program Files\Microsoft Office\Office14\Library
    'strPath = Application.LibraryPath
    
    '***XLSTARTフォルダ C:\Users\USERNAME\AppData\Roaming\Microsoft\Excel\XLSTART
    'strPath = Application.StartupPath
    
    '***ユーザーのテンプレートフォルダ C:\Users\USERNAME\AppData\Roaming\Microsoft\Templates
    'strPath = Application.TemplatesPath
    
    '***ユーザーのアドインフォルダ C:\Users\USERNAME\AppData\Roaming\Microsoft\AddIns
    'strPath = Application.UserLibraryPath
    
    '*** アクティブなブックが含まれているフォルダ
    'strPath = ActiveWorkbook.Path & "\"
    
    '*** 不明 ***
    'strPath = Application.AltStartupPath
    'strPath = Application.NetworkTemplatesPath
    
    'MsgBox strPath
    Shell "C:\Windows\Explorer.exe " & strPath, vbNormalFocus
End Sub

 

注:検索でなぜかこちらが引っかかっているようなので誘導します。
→【電子入札でSERVLET-ERROR-30001-J001JBC020が出た場合の対処法かもしれない最新の方法


本題

前々回の結果で、どうやら不要な「名前の定義」の「内容(Value)」には「#REF」が含まれていることが分かりました。それならば、

  • Valueに#REFが含まれていたら削除する

という図式が成り立ちますね。これなら最小限の追加で済みそうです。

「excel vba 含まれていたら」でgoogle検索してみると、以下のサイトが見つかりました。

■ 「~を含む」の条件式の書き方 (Ifステートメント) (事務職のためのExcelVBA入門講座)
http://vbaexcel.seesaa.net/article/140800155.html

例えば、objName.Value に abc が含まれていたら~ の場合、

If objName.Value Like "*abc*" Then ~

とするそうです。*はワイルドカード。
早速#REFでやってみたけどうまくいかない。エラーは起きないけどステップインで動かしてみるとIfステートメントのところでElseになってしまっている。ヘルプでLike演算子を調べてみると、#もワイルドカードだったというオチ(苦笑) #を抜いて *REF* でやってみると無事に動いたのでした。以下ソース、

Sub DeleteName5()
  Dim objName As Name
  For Each objName In ActiveWorkbook.Names
    If objName.Value Like "*REF*" Then
    objName.Delete
    End If
  Next
End Sub

「選んで消す」というよりは「エラーになっている組込み定義を削除する」マクロ、ですね。まあ、これとチェックしてtxtに吐くマクロと、名前を指定して削除するマクロの3つで楽に対処できるようになったのでこれでよしとしますかね。

それではまた会いましょう。 

 

前回の最後の奴を応用してみた(簡単に)。結果、削除できました(笑

Sub DeleteName2()
  On Error GoTo ErrorHandler
  Dim strNAME As String
  strNAME = InputBox("消したい名前を入れるんだ!", "入力")
  ActiveWorkbook.Names(strNAME).Delete
  Exit Sub
ErrorHandler:
  MsgBox "エラー番号:" & Err.Number & vbCrLf & _
         "エラーの種類:" & Err.Description, vbExclamation
End Sub

これは一個ずつなのでループさせるか、あるいはValueに#REFが含まれていたら消す、というなコードにすればいいのかなって思いました。これならFor each ~ in ~でもいけるし。

---

参考:マクロ作るときは、Visual Basic Editor表示させて追加→標準モジュールしてコーディング。名前を付けて保存でxxxxx.xlsmで保存。削除が完了したら標準モジュールのModule1とかを右クリックして解放します。また名前を付けて保存でxxxxx.xlsxで保存しなおす。以上

 

そろそろSyntaxhighlighter入れたい

Officeのバグ的なものってバージョンアップしても全く直ってませんですね。

「名前の定義」も同様で、外のブックからシートを移動やコピーしてくると出てくる

「移動またはコピーしようとしている数式またはシートには、移動またはコピー先のワークシートに既にある名前 'xxxx'が含まれています。この名前を使用しますか? はい、いいえ」

のエラーダイアログ。これについては、ネットで検索すると、例えば

Excel 2003 のシートコピー時に出る HTML_Control の名前の警告を消す (futuremix, 2010.11.3)

のようなマクロで全部消してしまうという方法が出てきます。しかし、自分で名前の定義をがっつりしてたりすると全部消してしまうのは勿体ないというかまた定義しなおすの面倒くさいというのもあり、それなら選んで削除できるマクロに改造してしまおうというのが今回のコンセプト。完全に思いつきです。現実逃避です。
 
 
・・・・久しぶりすぎてVBA忘れてました(笑
 
そんな訳でとりあえず「定義されている名前の"インデックス番号"と"名前"と"参照範囲"」をテキストファイルに書き出すマクロに改造してました。以下ソース、
Option Explicit

Sub CheckName()

  On Error GoTo ErrorHandler
  
  Dim objName As Name
  Dim strCom As String
  Dim strCom2 As String
  Dim fs As Object
  Dim a As Object
    
  strCom = ""
  strCom2 = ""
  
  For Each objName In ActiveWorkbook.Names
    'objName.Delete
    strCom = objName.Index & objName.Name & objName.Value & vbCrLf
    strCom2 = strCom2 & strCom
  Next objName
  
  'MsgBox strCom2
  
  Dim strFN As String
  strFN = ActiveWorkbook.Path & "\teigi.txt"
  
  Open strFN For Output As #1
  Print #1, strCom2
  
  Close #1
  
  Exit Sub
  
ErrorHandler:
  
    MsgBox "エラー番号:" & Err.Number & vbCrLf & _
           "エラーの種類:" & Err.Description, vbExclamation
           
End Sub
なんかもうちょっとスマートに書けそうですが、忘れてしまったのでそこら辺は勘弁して下さい。これで吐き出した結果がこちら、
1複相ひな形!_Key1=#REF!#REF!
2'模式図(坑口)'!_Key1=#REF!#REF!
3'模式図(底盤)'!_Key1=#REF!#REF!
4_Key1=#REF!#REF!
5_Key2=#REF!#REF!
6_Order1=0
7複相ひな形!_Sort=#REF!#REF!
8'模式図(坑口)'!_Sort=#REF!#REF!
9'模式図(底盤)'!_Sort=#REF!#REF!
10_Sort=#REF!#REF!
11_Sort2=#REF!#REF!
12'模式図(坑口)'!a=#REF!#REF!
13'模式図(底盤)'!a=#REF!#REF!
14a=#REF!#REF!
15N20130601_01=#REF!#REF!
16N20130601_02=#REF!#REF!
17機械準備時間=薬注条件!$B$6
18砂質土N値=薬注条件!$G$9:$G$11
19砂質土注入率=薬注条件!$G$9:$H$11
20砂礫土注入率=薬注条件!$G$12:$H$14
21単位引抜時間=薬注条件!$B$23
22単位削孔時間=薬注条件!$B$11:$C$13
23単位注入量=薬注条件!$C$18
24土質=薬注条件!$B$11:$B$13
25粘性土N値=薬注条件!$G$6:$G$8
26粘性土注入率=薬注条件!$G$6:$H$8
27礫質土N値=薬注条件!$G$12:$G$14
 どうやら1~16番あたりが不要な感じですね。#REFってるし。
 
次にやったのは、InputBoxを使ってインデックス番号を入力して削除していく的なマクロを組んでみたけどエラーで動きませんでした。エラーコードは9, インデックスが有効範囲にありません、とのこと。恥ずかしいのでソース出さない。
 
以下次号。
 
というか、VBAのヘルプでNamesオブジェクトのところを見ると、
 
次の使用例は、作業中のブックから "mySortRange" という名前を削除します。
ActiveWorkbook.Names("mySortRange").Delete
 
なんてのも書いていてそれで良いじゃないという気もしますね。
 
 

 工程表では、客先協議や関係機関協議などの「協議」を記すことも重要です。「協議」はピンポイントで行われるものなので、ラインではなく別の表示をしてやります。

ここでは▲としました。これは文字列の「▲」ではなく、Shapeオブジェクトの三角形です。

三角形を描画するメソッド、というか図形を描画するメソッドは、

expression.AddShape(Type, Left, Top, Width, Height)

Type : 描画する図形のタイプ (MsoAutoShapeType クラスの定数)
Left, Top : 描画する図形の左上の座標値 As Single
Width, Height : 描画する図形の幅と高さ As Single

です。

ここでは上向きの三角形なので、msoShapeIsoscelesTriangleとなります。既に述べたように、選択範囲の左上の座標値や幅、高さは取得できるので簡単です。

今回ちょっと工夫をしたところは、上図の青▲がライン上に、赤▲がセル上に描画されていますね。この両方のパターンを一つのボタン(プロシージャ)で出来るようにしたことです。

    ' 協議マークの開始座標、幅、高さを設定
    If Selection.Columns.Count = 1 Then
        X0 = SentakuLeft
        Y0 = SentakuTop
        W1 = SentakuWidth
        H1 = SentakuHeight
    Else
        X0 = SentakuLeft + (SentakuWidth / 4)
        Y0 = SentakuTop
        W1 = SentakuWidth / 2
        H1 = SentakuHeight
    End If

セルを1列選択したときと2列選択したときで図形左上の座標値、幅と高さの計算式を変えているだけです。単純です。

図形の描画についても、描画範囲外の場合や2行以上選択した場合、また上のコードに当てはまらない場合つまり3列以上選択した場合にはメッセージを出して処理を抜けます。

    ' 協議マークをプロットする
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, X0, Y0, W1, H1)
    
    ' 協議マークの塗りつぶしを設定
    shp.Line.Weight = 0.1
    shp.Line.ForeColor.RGB = RGB(ColorR, ColorG, ColorB)
    shp.Fill.Visible = True
    shp.Fill.ForeColor.RGB = RGB(ColorR, ColorG, ColorB)

最後に描画した三角形の色と塗りつぶし色を設定して終了です。 

 

完成したファイルを置いておきます。特にパスワードはかけていないので拙いコーディングですが、見てやって下さい。

 前回のコードでは、複数行を選択したときにでもその複数行の中央にラインが引かれてしまいます。工程表で必要なラインは一行で十分ですので、一行選択したときのみラインを引くように制限します。

    ' 2行以上の場合メッセージを出して終了
    If Selection.Rows.Count > 1 Then
        MsgBox "1行のみ選択して下さい。"
        Exit Sub
    End If

また、工程表のラインは「予定」と「実績」があります。ラインカラーを「予定=青」「実績=赤」とすることとし、条件分けによって同じコードでラインを引き分けることとします。

偶数・奇数行の選択はテンプレートによって変わるでしょうから、適宜修正して下さい。

    ' 選択行によるラインカラーの設定(偶数:青 奇数:赤)
    If (Selection(1).Row Mod 2) = 0 Then
        ColorR = 0
        ColorG = 0
        ColorB = 255
    Else
        ColorR = 255
        ColorG = 0
        ColorB = 0
    End If

    ' 工数ラインをプロットする
    With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).Line
        .ForeColor.RGB = RGB(ColorR, ColorG, ColorB)
        .Weight = 4
    End With

偶数・奇数の条件分けは選択した行番号を2で割って余りがなければ偶数行という単純な方法です。それぞれの場合に、RGBの数値を指定しておき、プロットに反映させます。

---

次に描画範囲の設定をします。設定というか、どこにでもラインが引けてしまうのは表としていかがなものかと思うので、指定した範囲外には描画できないようにします。これも最初に作るテンプレートにより変わるので適宜修正して下さい。

私が作ったテンプレートはこれです。

これについて、描画範囲は以下のようになります。

選択範囲の左上と右下が描画範囲を外れていれば描画させないようにします。

    ' 選択範囲が工程表外の場合メッセージを出して終了
    If Selection(1).Row < 10 Or Selection(1).Column < 6 Then
        MsgBox "描画範囲外です。"
        Exit Sub
    End If
    If Selection(Selection.Count).Row > 47 Or _
       Selection(Selection.Count).Column > 83 Then
        MsgBox "描画範囲外です。"
        Exit Sub
    End If

次回は「協議」時のアイコンの描画について書きます。

 

仕事をしていると必ず必要になるのが工程表ですが、これは専らExcelで作られることが多いです。かくいう自分も自分のニーズに合わせた工程表を作って管理をしています。工程表で予定と実績を示すラインはオートシェイプで描画していますが、これまでは手入力のオートシェイプでした。または元からあるラインをコピーして伸縮して使っていました。

これをVBAで自動描画出来ないかと考え、Shapeの描画について調べてみました。

最初にラインを引くメソッドをヘルプで検索してみました。

expression.AddLine(BeginX, Beginy, EndX, EndY)

BeginX, BeginY : 開始点のX,Y座標 As Single
EndX, EndY : 終了点のX,Y座標 As Single

それでは、狙った場所にラインを引くにはどうしたらよいでしょうか。狙った場所は選択範囲とすれば何かプロパティ値が取得できるような気がします。そこで調べてみると、以下の図のようなプロパティ値が取得できることが分かりました。

 

選択範囲については、まず左上の座標値(ピクセル単位)が取得できます。さらに幅と高さのピクセル数およびセル数が分かります。また、左上と右下のセルは特定でき、行番号および列番号が取得できます。

ラインを引く場合はピクセル座標値での指定なので、これらから計算させれば引くことが可能です。

それではコードです。ボタンを配置しておき、クリックでラインを引くようにします。

Private Sub CommandButton2_Click()

    Dim SentakuTop As Single      ' 選択範囲左上座標値 Y
    Dim SentakuLeft As Single     ' 選択範囲左上座標値 X
    Dim SentakuWidth As Single    ' 選択範囲幅
    Dim SentakuHeight As Single   ' 選択範囲高さ
    Dim SentakuAddress As String  ' 選択範囲アドレス
    Dim X0, Y0, X1, Y1 As Variant

    ' 選択範囲の取得(相対指定のExcel形式:ex. A1:A9)
    SentakuAddress = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)

    ' 選択範囲左上の座標値および選択幅、選択高さを取得(ピクセル単位)
    With ActiveSheet.Range(SentakuAddress)
        SentakuTop = .Top
        SentakuLeft = .Left
        SentakuWidth = .Width
        SentakuHeight = .Height
    End With
            
    ' 工数ラインの開始座標、終了座標を計算
    X0 = SentakuLeft
    Y0 = SentakuTop + SentakuHeight / 2
    X1 = SentakuLeft + SentakuWidth
    Y1 = Y0
    
    ' 工数ラインをプロットする
    With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).Line
        .ForeColor.RGB = RGB(0, 0, 255)
        .Weight = 4
    End With

End Sub

選択範囲の取得は絶対指定でも良さそうです。

ちなみにLineFormatのプロパティは、オブジェクトブラウザで見ると以下のようになっています。

 

 

2010年、明けました。今年の抱負。

ついに2010年です。未だに宇宙旅行は実現されていないのですね。

そんな訳で、今頃となりましたが、明けましておめでとうございます。

今年はニュース系の話題は少し控え目にして、本来のプログラミングの方の記事を細々と書いていこうと思います。初心者なので参考にならないとは思いますがお付き合い下さい。

宜しくお願い致します。

最近VBとかVBAの記事がさっぱりですが、何もやっていないわけではないのです(笑) 実は、今ひとつExcel VBAで組んでいるものがありまして、それがやっと完成した(というか実は既に完成していた・・・)のです。その内容はともかくとして、苦労していた内容の方、これが判明したと同時に、ある意味意外な落とし穴だったのだなぁということを痛感したのでご紹介します。

Excel VBAでセルの内容や変数をクリップボードに取り込むには、皆さんご存知のように、ClipboardオブジェクトにSetTextしてPutInClipboardすることで可能です。一応書いておくと、

Option Explicit

Private Sub CommandButton1_Click()

    Dim txtA As String
    Dim txtB As String
    Dim txtC As String
    Dim CB As New DataObject
    
    txtA = Worksheets("Sheet1").Cells(2, 2)
    txtB = Worksheets("Sheet1").Cells(2, 4)
    
    txtC = txtA & txtB
    
    With CB
        .SetText txtC
        .PutInClipboard
    End With

End Sub

このような感じになります。

そこで問題が発生しました。これでクリップボードにコピーできたな、と思い、普段使っているテキストエディタを立ち上げて貼り付けしました。

・・・・・・・・・貼り付かない。「編集」→「貼り付け」という項目が出ているのでクリップボードには確かに何かが入っています。それなのに何度Ctrl+Vしても貼り付かないのです。

困った困ったと、IRCでネット仲間に助けを求めました。そしていくらかのやり取りの後判明したこと。それは・・・・

 

クリップボードに入っているのは「Unicode文字列」 だということです。

 

文字列オブジェクトには「文字列」と「Unicode文字列」というのがあるそうです。テキストエディタのアプリケーションで「貼り付け」という作業をすると、実際にはアプリケーションがクリップボード内の「文字列」あるいは「Unicode文字列」を読みに行くのだそうです。

私が使っていたエディタはUnicode非対応のもので、そのアプリケーションは「文字列」の方を読みにいってしまったのではないか、ということでした。事実、Windows付属のメモ帳で「貼り付け」を行ったところ見事に貼り付きましたので。

そういう訳で、実際にはちゃんと「Unicode文字列」としてクリップボードに格納されていた、ということでした。

----

上記のコードは確認のために書いた簡単なもので、実際には結構長い奴を書いていました。そちらはこのブログの別のエントリーに利用しています。CDアルバムの情報をHTMLタグにするものです。Movable Typeのエディタ内の改行はLFのようで、前にHTMLのtableを貼り付けたときに気づきました。それでまあvblfで書き込めばいいかと思いExcel VBAでコーディングしたのです。私のずいぶん前のエントリーですが、

MP3タグ情報を元にCDアルバムからHTMLのtableを作成する

というのがありましたが、これに関連するものです。本当はVB.NETでDataGridViewを使うのが正解なのでしょうけど、何せこのDataGridViewというのが難しい(私には)のです。なので手っ取り早くExcelでやっちゃえってことに・・・(汗

【蛇足】 せっかくExcel VBAにしたので、収録時間を合計させてtableに追加、というのはやっていますけどね。

カスタム検索
Access Counter
Powered by Movable Type 4.22-ja

2016年9月

Sun Mon Tue Wed Thu Fri Sat
        1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30