Excelマクロのメモ

「月/日」なデータをExcelシートに入力したら勝手に「今年/月/日」になって困ったことはありませんか。私はあります。
一つ２つなら手で治すんですが3000件位あるデータの中のあちこちにそういうのがあって一つ一つ潰してくのが嫌だったのでマクロ書いてました。
多分数年後にまた使うと思うので日記に残しておきます。

Option Explicit

' 選択範囲にある日付の年だけを指定した年に変更する
Sub changeYear()
    Dim rw, cl, dt, cy, rng, dstr
    If TypeName(Selection) = "Range" Then
        Set rng = Selection
        cy = InputBox("変更したい年を指定してください", "年だけ変更", Year(Date))
        If IsNumeric(cy) = False Then Exit Sub
        If CInt(cy) < 1900 Then Exit Sub
        For rw = 1 To rng.Rows.Count
            For cl = 1 To rng.Columns.Count
                dt = rng.Cells(rw, cl).Value
                If IsDate(dt) = True Then
                    dstr = cy & "/" & Format(dt, "mm/dd")
                    rng.Cells(rw, cl) = dstr
                    'Debug.Print dstr
                End If
            Next cl
        Next rw
    End If
End Sub

前は結構普通の日記も書いてたのに最近なんかマクロの保管場所でしか使ってない気がする。

Excel VBA でカタカナを全角に、英数字&記号を半角にするマクロ

半角カナと全角英数字のない世界に行きたい。

' アクティブシートの選択しているセルを含む範囲内の半角カナを全角に、全角英数字を半角にする
' マクロの参照設定に "Microsoft VBScript Regular Expressions 5.5" を追加する
Sub han2zenkana()
    Dim r As Long, c As Long
    Dim re As RegExp
    Dim rng As Range
    Dim dat, rdat
    Dim m, matches
    
    Set re = New RegExp
    re.Global = True
    re.Pattern = "[Ａ-Ｚａ-ｚ０-９／．，（）　]"
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    Set rng = Selection.CurrentRegion
    rng.Select
    For r = 1 To rng.Rows.Count
        For c = 1 To rng.Columns.Count
            dat = rng.Cells(r, c).Formula
            If InStr(dat, "=") <> 1 And Len(dat) > 0 Then ' 関数でない場合のみ
                dat = StrConv(dat, vbWide) ' 一度全て全角に
                Set matches = re.Execute(dat)
                For Each m In matches
                    dat = Replace(dat, m.Value, StrConv(m.Value, vbNarrow))
                Next m
                rng.Cells(r, c) = dat
                Debug.Print r & " " & dat
            End If
        Next c
    Next r
       
End Sub

追記：
以前書いたこのエントリの存在を忘れて正規表現使わないバージョンの関数書いてしまった。

' 指定したRange内の半角カナを全角に、全角英数字を半角にする
Function Han2Zen(rng As Range)
    Dim han, zen, c
    Dim i As Integer
    
    han = Array( _
    "ｳﾞ", "ｯ", "ｬ", "ｭ", "ｮ", _
    "ｶﾞ", "ｷﾞ", "ｸﾞ", "ｹﾞ", "ｺﾞ", _
    "ｻﾞ", "ｼﾞ", "ｽﾞ", "ｾﾞ", "ｿﾞ", _
    "ﾀﾞ", "ﾁﾞ", "ﾂﾞ", "ﾃﾞ", "ﾄﾞ", _
    "ﾊﾞ", "ﾋﾞ", "ﾌﾞ", "ﾍﾞ", "ﾎﾞ", _
    "ﾊﾟ", "ﾋﾟ", "ﾌﾟ", "ﾍﾟ", "ﾎﾟ", _
    "ｱ", "ｲ", "ｳ", "ｴ", "ｵ", _
    "ｶ", "ｷ", "ｸ", "ｹ", "ｺ", _
    "ｻ", "ｼ", "ｽ", "ｾ", "ｿ", _
    "ﾀ", "ﾁ", "ﾂ", "ﾃ", "ﾄ", _
    "ﾅ", "ﾆ", "ﾇ", "ﾈ", "ﾉ", _
    "ﾊ", "ﾋ", "ﾌ", "ﾍ", "ﾎ", _
    "ﾏ", "ﾐ", "ﾑ", "ﾒ", "ﾓ", _
    "ﾔ", "ﾕ", "ﾖ", "ｰ", "･", _
    "ﾗ", "ﾘ", "ﾙ", "ﾚ", "ﾛ", _
    "ﾜ", "ｦ", "ﾝ", "｢", "｣", _
    "ｧ", "ｨ", "ｩ", "ｪ", "ｫ")

    zen = Array( _
    "ヴ", "ッ", "ャ", "ュ", "ョ", _
    "ガ", "ギ", "グ", "ゲ", "ゴ", _
    "ザ", "ジ", "ズ", "ゼ", "ゾ", _
    "ダ", "ヂ", "ヅ", "デ", "ド", _
    "バ", "ビ", "ブ", "ベ", "ボ", _
    "パ", "ピ", "プ", "ペ", "ポ", _
    "ア", "イ", "ウ", "エ", "オ", _
    "カ", "キ", "ク", "ケ", "コ", _
    "サ", "シ", "ス", "セ", "ソ", _
    "タ", "チ", "ツ", "テ", "ト", _
    "ナ", "ニ", "ヌ", "ネ", "ノ", _
    "ハ", "ヒ", "フ", "ヘ", "ホ", _
    "マ", "ミ", "ム", "メ", "モ", _
    "ヤ", "ユ", "ヨ", "ー", "・", _
    "ラ", "リ", "ル", "レ", "ロ", _
    "ワ", "ヲ", "ン", "「", "」", _
    "ァ", "ィ", "ゥ", "ェ", "ォ")

    For Each c In rng.Cells
        c.Value = Application.WorksheetFunction.Asc(c.Text)
    Next c
    
    With rng
        For i = 0 To 84
            .Replace What:=han(i), Replacement:=zen(i), LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        Next i
    End With
End Function

こちらからは以上です。

Visustin Pro 版の Editor 機能早見表

Visustin – フローチャートジェネレイター っていうソース解析用のツールがある。

こんな感じで左側のボックスにソースを貼り付け、Drawボタンを押すと右側にフローチャートを書いてくれる。
解析だけなら無料版でも可能、且つたくさんの言語パターンに対応してるのでとても便利。

ただ、自動作図されたものは用紙枠などを考慮してないので、そのまま印刷しようとすると一部だけちょびっとはみ出たりして悲しいことに。

Pro版を購入すると、解析したデータを編集できるエディタがついてくる。上記のフローチャートを編集したのがこれ。Visioほどじゃないけど、コネクタ線の形状が選べるし後から図形を挿入したりもできるので、結構見栄えの良いものができる。

てことで、仕事で使おうと思ってPro版を買ったので、編集機能の練習がてら Editor の図形編集でできることをまとめた一覧を作った。メモ代わりに以下に貼り付けておく。

Pro版5万もするんで（それでもこの手のソフトの中では安い方らしいのだけども）どんだけの人が持ってるかわからんですがまあ。

Excel VBA 小ネタマクロ

例によって仕事中に現実逃避で作ったマクロを日記へメモっておこうと思ったら、久しぶりすぎてはてな記法忘れてる私です、こんにちは。

指定の列のデータを複数の列に振り分けるマクロ

説明が面倒くさいんでビフォーアフターを画像で貼り付けます。

これが、

こうなる

以下ソース。あ、内部でRangestrって自作関数使ってるのでそっちのソースもご利用下さい

'-----------------------------------------------------------------------
Sub 行列入れ替えテスト()
    RowToColumns ActiveSheet, 1, 3
End Sub

'-----------------------------------------------------------------------
' 指定の列の値を指定の行数ごとに隣の列にコピーして空になった行を削除するマクロ
Sub RowToColumns(sh As Worksheet, col As Long, cols As Long)
    Dim dr As Long, er As Long
    Dim i
        
    For i = 1 To cols ' コピー先の列を作る
        sh.Columns(col + 1).Insert
    Next i
    
    er = 0
    dr = 1
    
    Do While er < 100
        
        If sh.Cells(dr, col).Value = "" Then
            er = er + 1 ' データがない行はスキップ
        Else
            er = 0
            Application.ScreenUpdating = False
            sh.Range(RangeStr(dr + 1, col, dr + (cols - 1), col)).Copy
            sh.Cells(dr, col + 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
            Application.CutCopyMode = False
            sh.Rows(RowsStr(dr + 1, dr + (cols - 1))).Delete Shift:=xlUp
            Application.ScreenUpdating = True
        End If
        
        dr = dr + 1
    Loop
                    
End Sub

指定の列にデータがない行を削除するマクロ

これも面倒なんでビフォーアフター画像から察して下さい。

これが

こうなる

サンプルみたいな単純な表だとNo.列でソートしてから削除するほうが手っ取り早いんですが、大人の事情でソートしちゃうと前後がぐちゃぐちゃになって再利用しにくい表などもあるのです。

以下ソース。

'-----------------------------------------------------------------------
' 指定範囲の空行を削除する
Sub 空行削除()
    Dim sh As Worksheet
    Dim sel As Range
    
    If TypeName(Selection) = "Range" Then
        Set sh = ActiveSheet
        Set sel = Selection
        EmptyRowDelete sh, sel.Row, sel.Row + sel.Rows.Count, 2
    End If
End Sub

'-----------------------------------------------------------------------
' 指定の列にデータが含まれない行を削除するマクロ
' チェックする列は３つまで
'-----------------------------------------------------------------------
' 指定の列にデータが含まれない行を削除するマクロ
' チェックする列は３つまで
Sub EmptyRowDelete(sh As Worksheet, srow As Long, erow As Long, _
            col1 As Long, Optional col2 As Long = 0, Optional col3 As Long = 0)
    
    Dim r As Long, cf1 As String, cf2 As String, cf3 As String
    
    cf1 = ""
    cf2 = ""
    cf3 = ""
    For r = erow To srow Step -1
        If col1 > 0 Then
            cf1 = sh.Cells(r, col1).Value
        End If
        If col2 > 0 Then
            cf2 = sh.Cells(r, col2).Value
        End If
        If col3 > 0 Then
            cf3 = sh.Cells(r, col3).Value
        End If
        If cf1 = "" And cf2 = "" And cf3 = "" Then
            sh.Rows(r).Delete Shift:=xlUp
        End If
    Next r
End Sub

いわずもがなですが

例によってエラーチェックとかいろいろ気遣いをしてないマクロなので、使った結果何が起きてもフォローできません。
実行の際は直前に文書を保存したり、シートをコピーしたりして万全の準備整えておいていただけると幸いです。

ネットにつながんなくなった

先日来、なぜか会社のマイPCがインターネットにつながらなくなった。

といっても同じローカルネット内にぶら下がってるNASやプリンタにはつながるので普段の仕事にはほぼ差し障りがなく、ちょっと調べ物をしようとしてネットを見ようとしたりメールを確認しようとしないかぎり気が付かない。

（あと息抜きでついった見ようとか思わない限りな！ …なのでまあ割とすぐに気が付いたわけだが＾ｑ＾）

ネットワークセンターで確認すると、社内ネットワークのほかに識別されていないネットワークというのが存在する。これのせいで外に出ていけなくなってるらしい。

まて、ネットワークアダプタはオンボの一個だけなのになんでネットワーク二つあるの。

いぶかしみながらPCを再起動すると、この「識別されてないネットワーク」は消えて、外に出ていけるようになった。

が、次の日またPCの電源入れると「識別されてないネットワーク」が復活する。再起動すれば消えるが面倒くさい。次の日はデバイスマネージャでオンボのネットワークアダプタを無効＞有効に切り替えるだけでも消えるのが分かったけど、それもやっぱ毎朝やるのは面倒くさい。

なんだろうなあ……、ここ最近PC周りで変わったことといえば、10年くらい使ってた有線ルータの調子が悪くなったので新しいルータに置き換えたくらいだ。他のPCは(持ち込んでる個人用のノートなども含め)なんともないので、このPCのなにかだけが新しいルータと相性が悪いのかもしれない。

再起動してネットにつながるようになってからぐぐってみたら、この、識別されてないネットワークのせいでインターネットにつながらなくなるという問題は Windows だとよくあることらしい。

しかし自分ところがなぜこうなったかはわからなかった。

識別されていないネットワークができちゃうのは Bonjour が悪さしてるという情報が一番上にあって、確かにこのPCには Adobe CS3 入ってるけどサービス一覧に Bonjour いないし、そもそもルータ変えるまでは今の環境で問題なかったのだし

……まあ原因は分からないけど治ればいいやと割り切る。

で、route コマンドでいらないデフォルトゲートウェイを消し、正しいデフォルトゲートウェイを設定しなおす、という対策方法をゲット。

参考にしましたありがとう→ 俺の覚書 Windows7が急にネットワークに繋がらなくなった

次の日、電源入れた直後のネットにつながらない状態でメモした通りに route コマンド打ち込んでデフォルトゲートウェイが正しく設定され、ネットにもつながることを確認し、一安心。

んで次の日。またつながらなくなってるー！

ipconfig みたらデフォルトゲートウェイに 0.0.0.0 が復活してる shit

で route コマンドを再入力。えーこれ毎日やんのか面倒。

てことでバッチファイルを作成。ログオン時にバッチファイルを管理者権限で実行させるやり方をググり、タスクスケジューラに登録。

これで明日からは幸せになれるのだろうか。

ていうか何が悪いんだろうなあほんと……。

Windows 7 のスタートアップフォルダ

勝手にアプリケーションをスタートアップ登録してくれるおせっかいなインストーラのせいで半年ごとに探すはめになるので、メモ。

すべてのユーザー

%SystemDrive%:\Users\All Users\Microsoft\Windows\Start Menu\Programs\Startup

自分専用

%SystemDrive%:\Users\%USERNAME%\AppData\Roaming\Microsoft\Windows\Start Menu\Programs\Startup

二か所あるのがまたうざい。
WindowsXPまではスタートボタン右クリックでフォルダ表示できたのに何でやめちゃったんでしょうね。

こっからは、絶対パスがわかればいいって人にとってはどうでもいい話。

↑上記のシステムドライブやユーザー名部分を環境変数で書いてるわけだがシステムドライブを表す環境変数名が自信なかったので、一応公開前にネットで検索して確認することにした。

最初に見つけたのが@ITにあったシステム環境変数とその変数がさす内容のリスト。しかし、このリストは書かれたのが2003年なため、内容もWindows98からXPまでと古い。環境変数自体は今でも使えるものだけど、フォルダの絶対パスはずいぶんと変わってきているんだなあと思った。

新しいバージョンはないのかとさらに検索を続け、Microsoft公式にちゃんとWindows 7と8でのデフォルトパスが乗っている環境変数一覧があるのを発見した。しかもよくよく見るとスタートアップフォルダの位置も載っているじゃあないですか。

環境変数で調べればもっと早くスタートアップの位置が分かったのかあ……。と、今更。

あ、Windows 8 もWindows 7と同じ位置のままみたいです。よかったね。（追記：Windows 10 も同じでした。やったね）

列名変換

久々にExcelでマクロ組んでいて列名を数字に変換しないといけない部分が出てきた。

そういえば、ずいぶん前のはてブにExcelの列名変換をお題にプログラミングコンテストをして〜というエントリが上がってて、自分でもやってみようとVBAで作ってみた記憶があった。が、マイドキュメントあさってみたがそれっぽいファイルが残っていない。

お題があったblogの別エントリで回答がのっていたはずだし、ブコメや関連リンクでさまざまな回答寄せられていたことは覚えてる。たぶんブックマークからたどればそれらを見つけることは可能。だが、何となく悔しいので、あえて元エントリも回答も見ずに作り直してみた。

Option Explicit

Sub test()
    Dim s As String
    Dim i, c
    For i = 1 To 1000
        s = ColStr(i)
        c = StrCol(s)
        Sheets("Sheet2").Cells(i, 1).Value = i
        Sheets("Sheet2").Cells(i, 2).Value = s
        Sheets("Sheet2").Cells(i, 3).Value = c
    Next i
End Sub

' 文字列から列番号を返す
Function StrCol(cs As String)
    Dim up, l, i, r, c
    up = StrConv(cs, vbUpperCase)
    l = Len(cs)
    r = 0
    If l > 0 Then
        For i = 0 To (l - 1)
            c = Asc(Mid(up, l - i, 1)) - &H40
            r = r + ((26 ^ i) * c)
        Next i
    End If
    StrCol = r
End Function

' 列番号から文字列を返す(A〜ZZZ)
Function ColStr(c) As String
    Dim C1, C2, C3, cc
    If c > (676 + 26) Then
        C1 = Int(Int(c / 26) / 26)
        C2 = Int(Int(c / 26) Mod 26)
        C3 = c Mod 26
        If C2 = 0 Then C1 = C1 - 1: C2 = 26
        If C3 = 0 Then C2 = C2 - 1: C3 = 26
        ColStr = Chr(C1 + &H40) & Chr(C2 + &H40) & Chr(C3 + &H40)
    ElseIf c > 26 Then
        C1 = Int(c / 26)
        C2 = c Mod 26
        If C2 = 0 Then C1 = C1 - 1: C2 = 26
        ColStr = Chr(C1 + &H40) & Chr(C2 + &H40)
    ElseIf c > 0 Then
        ColStr = Chr(c + &H40)
    End If
End Function

VBAエディタを開いてからStrColを正しく動くようにするまでに45分。変換のロジックはわかっていたものの、どういう関数を使ってどう評価させればいいのかという部分でだいぶ時間を食ったなあという感想。

検算用に使っているColStrはこれまた必要に迫られてずいぶん前に作った関数（d:id:Nikki_A:20100728）。本当は再帰など駆使して作るべきものなんだろうけど、現在のExcelの仕様では３ケタあれば十分なのでこのままでいっかーと放置してある。

と。

ここまで元エントリ読まずに書きあげ、それから自分のブクマの過去ログあさって発掘してきた。

http://blog.jnito.com/entry/20111102/1320253815 ＜元記事
http://b.hatena.ne.jp/entry/blog.jnito.com/entry/20111102/1320253815 ＜ブクマ

ああ……問題２の存在を忘れていた。ColStrをきちんと作り直すか。また忘れたころに。