« 2010年2月 | トップページ | 2010年4月 »

2010年3月

2010年3月31日 (水)

HTMLファイルの目次を作る

指定したフォルダ内のHTMLファイルのリンクを一列に並べた
目次のようなHTMLファイルを作ります。

HTMLファイルを作るといっても
タグの生成までで
生成したタグはメモ帳などで
HTML形式で保存してください。

手順は、指定したフォルダ内を
ワイルドカードを使って
「*.htm*」で検索して
見つかったHTMLファイルをリンクにしていきます。

HTML形式の拡張子は
.htmlと.htmの2つあるので、
「*.htm*」で検索すると両方が含まれます。

タグAの属性hrefにファイル名を、
タグAの表示もファイル名にします。

生成したタグはイミディエイトウィンドウに出力します。
これをコピペして使います。

フルパスではなくファイル名だけをhref属性に指定してますので
リンク先のHTMLファイルと同じフォルダ内に
作った目次のHTMLファイルを置きます。

コードはこちら

HTMLファイルの目次を作るコード：

Sub macro100330a()
'指定したフォルダ内の
'HTMLファイルの目次を作る

    SheetAddDel ("macro100330a")
    Dim MyPath As String, MyFile As String
    Dim MyHTML As String
    Dim i As Integer
    MyHTML = "<HTML><BODY>" & Chr(10)
   
    'フォルダを指定する
    MyPath = "C:\"
   
    'ファイルの有無を確認
    With Application.FileSearch
        .LookIn = MyPath
        '
        .Filename = "*.htm*"
        If .Execute() > 0 Then
            MsgBox .FoundFiles.count & _
                " 個のファイルが見つかりました。"
            For i = 1 To .FoundFiles.count
                MyHTML = MyHTML & "<A href = " & Chr(34) _
                    & Dir(.FoundFiles(i)) & Chr(34) & ">" _
                    & Dir(.FoundFiles(i)) & "</A><BR/>" & Chr(10)
               
            Next i
        Else
            MsgBox "検索条件を満たすファイルはありません。"
        End If
    End With
    MyHTML = MyHTML & "</BODY></HTML>"
    Debug.Print MyHTML
End Sub

実行後のイミディエイトウィンドウの一例
Vba20100331a

これをメモ帳にコピペして
HTML形式で保存すると
指定したフォルダ内のすべてのHTMLファイルのリンクが並んだ
目次ができる。

いつか作ったHTMLファイルやいつか保存したHTMLファイルなど
一個一個開いて見るより便利だと思います。

2010年3月31日 (水) | | コメント (0) | トラックバック (0)

2010年3月28日 (日)

Patternの見本

Patternの見本をつくります。

コードはこちら

Patternの見本を作るコード：

Sub macro100328a()
'Pattern見本
    SheetAddCDel ("Pattern見本")
    Dim i As Integer
    Dim ValuePattern, StrPattern
    ValuePattern = Array(xlPatternAutomatic, xlPatternChecker, _
        xlPatternCrissCross, xlPatternDown, xlPatternGray16, _
        xlPatternGray25, xlPatternGray50, xlPatternGray75, _
        xlPatternGray8, xlPatternGrid, xlPatternHorizontal, _
        xlPatternLightDown, xlPatternLightHorizontal, _
        xlPatternLightUp, xlPatternLightVertical, xlPatternNone, _
        xlPatternSemiGray75, xlPatternSolid, xlPatternUp, _
        xlPatternVertical)

    StrPattern = Array("xlPatternAutomatic", "xlPatternChecker", _
        "xlPatternCrissCross", "xlPatternDown", "xlPatternGray16", _
        "xlPatternGray25", "xlPatternGray50", "xlPatternGray75", _
        "xlPatternGray8", "xlPatternGrid", "xlPatternHorizontal", _
        "xlPatternLightDown", "xlPatternLightHorizontal", _
        "xlPatternLightUp", "xlPatternLightVertical", "xlPatternNone", _
        "xlPatternSemiGray75", "xlPatternSolid", "xlPatternUp", _
        "xlPatternVertical")
       
    Cells(1, 2) = "表示"
    Cells(1, 4) = "Pattern"
       
    For i = 0 To 19
        Range("B" & 3 + 2 * i).Interior.Pattern = ValuePattern(i)
        Range("C" & 3 + 2 * i) = i
        Range("D" & 3 + 2 * i) = StrPattern(i)
    Next i
End Sub

実行後のシート

Vba20100328a

Vba20100328b

画面で見る分には、カラーでも問題ないですが、
印刷を白黒でする場合のセルの背景は
色よりもパターンの方が見やすいかもしれません。

そこで、色をパターンで置き換えたいと思います。

アクティブシートの使用範囲内のセルを調べて、
指定したColorIndexの背景を持つセルを
指定したパターンに置き換えます。

逆もあります。

コードはこちら

色をパターンで置き換えるコード：

Sub macro100328b()
'ColorToPattern使用例
    Call ColorToPattern(38, 1)
End Sub

Sub ColorToPattern(C As Integer, i As Integer)
'セルの背景を色の塗りつぶしから
'白黒パターンへ変換
'C = ColorIndexを指定
'i = Patternを入れた配列のインデックスを指定

    Dim obj As Object
    Dim ValuePattern As Variant
    ValuePattern = Array(xlPatternAutomatic, xlPatternChecker, _
        xlPatternCrissCross, xlPatternDown, xlPatternGray16, _
        xlPatternGray25, xlPatternGray50, xlPatternGray75, _
        xlPatternGray8, xlPatternGrid, xlPatternHorizontal, _
        xlPatternLightDown, xlPatternLightHorizontal, _
        xlPatternLightUp, xlPatternLightVertical, xlPatternNone, _
        xlPatternSemiGray75, xlPatternSolid, xlPatternUp, _
        xlPatternVertical)
       
    For Each obj In ActiveSheet.UsedRange
        If obj.Interior.ColorIndex = C Then
            obj.Interior.ColorIndex = xlNone
            obj.Interior.Pattern = ValuePattern(i)
        End If
    Next obj
End Sub

パターンを色で置き換えるコード：

Sub macro100328c()
'PatternToColorの使用例
    Call PatternToColor(1, 38)
End Sub

Sub PatternToColor(i As Integer, C As Integer)
'セルの背景をパターンから
'塗りつぶしへ変換
'C = ColorIndexを指定
'i = Patternを入れた配列のインデックスを指定

    Dim obj As Object
    Dim ValuePattern As Variant
    ValuePattern = Array(xlPatternAutomatic, xlPatternChecker, _
        xlPatternCrissCross, xlPatternDown, xlPatternGray16, _
        xlPatternGray25, xlPatternGray50, xlPatternGray75, _
        xlPatternGray8, xlPatternGrid, xlPatternHorizontal, _
        xlPatternLightDown, xlPatternLightHorizontal, _
        xlPatternLightUp, xlPatternLightVertical, xlPatternNone, _
        xlPatternSemiGray75, xlPatternSolid, xlPatternUp, _
        xlPatternVertical)
       
    For Each obj In ActiveSheet.UsedRange
        If obj.Interior.Pattern = ValuePattern(i) Then
            obj.Interior.Pattern = xlPatternNone
            obj.Interior.ColorIndex = C
            
        End If
    Next obj
End Sub

2010年3月28日 (日) | | コメント (1) | トラックバック (0)

2010年3月27日 (土)

LineStyleの見本

セルの枠線、LineStyleとWeightの表をつくります。

コードはこちら

LineStyleの見本を作るコード：

Sub macro100327a()
'LineStyle見本

    SheetAddCDel ("LineStyle見本")
    Dim i As Integer, j As Integer
    Dim ValueLineStyle, StrLineStyle As Variant
    Dim ValueLineWeight, StrLineWeight As Variant
    ValueLineStyle = Array(xlContinuous, xlDash, xlDashDot, _
        xlDashDotDot, xlDot, xlDouble, xlSlantDashDot, xlLineStyleNone)
    StrLineStyle = Array("xlContinuous", "xlDash", "xlDashDot", _
        "xlDashDotDot", "xlDot", "xlDouble", "xlSlantDashDot", "xlLineStyleNone")
    ValueLineWeight = Array(xlHairline, xlThin, xlMedium, xlThick)
    StrLineWeight = Array("xlHairline", "xlThin", "xlMedium", "xlThick")
   
    Cells(1, 1) = "LineStyle/Weight"
    For i = 0 To 3
        Cells(1, 3 + i * 2) = StrLineWeight(i)
        Range(toA1("C" & 2 + i * 2)).ColumnWidth = 2
    Next i
    For i = 0 To 7
        Range("A" & 3 + 2 * i) = StrLineStyle(i)
        With Range("C" & 3 + 2 * i).Borders
            .LineStyle = ValueLineStyle(i)
            .Weight = ValueLineWeight(0)
        End With
        With Range("E" & 3 + 2 * i).Borders
            .LineStyle = ValueLineStyle(i)
            .Weight = ValueLineWeight(1)
        End With
        With Range("G" & 3 + 2 * i).Borders
            .LineStyle = ValueLineStyle(i)
            .Weight = ValueLineWeight(2)
        End With
        With Range("I" & 3 + 2 * i).Borders
            .LineStyle = ValueLineStyle(i)
            .Weight = ValueLineWeight(3)
        End With
    Next i
    Columns(1).AutoFit
End Sub

実行後のシート
Vba20100327a

2010年3月27日 (土) | | コメント (0) | トラックバック (0)

2010年3月26日 (金)

別のシートのセルと同期する

同じシート内であるセルとあるセルを同期するには
セルを参照します。
例えば、A1セルをB1セルと同期させるには
A1セルに次のように入力します。

=B1

別のシートのB1セルを参照するには

='シート名'!B1

のように、シングルクォーテーションではさんだシート名の後に
「!」を付けてセルのアドレスを続けます。

同じシート内のセルを参照しても
異なるシートのセルを参照しても
参照先のセルが空白だと「0」が表示されてしまいます。

次の画像は、セルA1に「=B1」と入力した場合、
セルB1が空白なのでセルA1は「0」になっています。
Vba20100326a

必要のない「0」が表示されると見にくいので
これをなくします。

ワークシート関数を使って解決します。

手順は、まず参照先のセルが空白かどうかかを判定します。
参照先のセルが空白なら参照元のセルも空白に、
空白でないのなら参照先セルをそのまま参照します。

空白かどうかの判定は、
ISBLANK関数を使います。
簡単な使用例を示します。

セルA1が空白のとき、
ISBLANK(A1)の値はTRUEです。

ISBLANK(A1) = TRUE

これを論理関数IFの条件判断の部分に使います。

IFの使い方は、

IF(論理式, 真の場合, 偽の場合)

で、個人的に分かりやすくすると

IF（条件, TRUEの場合の値, FALSEの場合の値）

です。
さて、材料が揃ったのでまとめます。

セルA1でセルB1を参照して
セルB1が空白ならセルA1も空白に、
セルB1が空白でないのならその値をセルA1の表示する
セルA1の数式です。

=IF(ISBLANK(B1), "", B1)

これをセルA1に入力したときの画像
セルB1が空白のときA1も空白
Vba20100326b

セルB1が空白でないときの画像
Vba20100326c

最初に説明したように、
別のシート（シート名をSheet2とする）のB1でこの数式を使うには

=IF(ISBLANK('Sheet2'!B1), "", 'Sheet2'!B1)

のようにします。

これを何に使うかというと
記事「月間カレンダー、祝日あり 」で作った
月間カレンダーの日付けのセルと
その元となった年間カレンダーのセルと同期させて
祝日だけでなく
個人的なスケジュールも組み込むのに使います。

月間カレンダーの方は1日で5行1列分を使っています。
最初の1行は日付けと祝日で
残りの4行分が自由にできます。

この4行分が年間カレンダーの同じ日付けの行の
C列からF列に対応します。

上記記事内のコードmacro100324aを
改造したコードはこちら

月間カレンダー、祝日あり2を作るコード：

Sub macro100326a()
'月間カレンダー、祝日あり2
'1シートひと月

    Dim i, j, k As Integer
    Dim MyYear, MyMonth As Integer
    MyYear = 2010
    MyMonth = 0
    Dim SheetA, SheetB As Object
    Set SheetA = Sheets(MyYear & "年カレンダー")
    Dim MyRange As Range
    Dim StrWeekDay As Variant
    StrWeekDay = Array("月", "火", "水", "木", "金", "土", "日")
    Dim EndRow, MRow, MCol As Integer
    EndRow = SheetA.Range("A1").End(xlDown).Row
   
    For i = 2 To EndRow
        '月が替わったらシートを挿入
        If MyMonth <> Month(SheetA.Cells(i, 1)) Then
            MyMonth = Month(SheetA.Cells(i, 1))
            SheetAddDel (MyYear & "年" & MyMonth & "月")
            Set SheetB = Sheets(MyYear & "年" & MyMonth & "月")
            
            'なんとなくページ設定
            'まだよくわかってないけど
            With SheetB.PageSetup
                .PrintArea = "$A$1:$G$37"
                .Zoom = False
                .CenterHorizontally = True
                .PaperSize = xlPaperA4
                .FitToPagesTall = 1
                .FitToPagesWide = 1
            End With

            SheetB.Cells(1, 1) = MyMonth & "月"
            SheetB.Cells(1, 1).Font.Size = 24
            
            SheetB.Cells(1, 7) = MyYear & "年"
            SheetB.Cells(1, 7).Font.Size = 16
            
            For j = 1 To 7
                '曜日の文字を入れる
                Cells(2, j) = StrWeekDay(j - 1)
               
                '日ごとの枠を設定、6週分(固定)
                For k = 3 To 3 + 5 * 6 Step 5
                    Set MyRange = Range(toA1("R" & k & "C" & j & ":R" & k + 4 & "C" & j))
                    With MyRange.Borders(xlEdgeLeft)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With MyRange.Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With MyRange.Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With MyRange.Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                Next k
            Next j
            
            '曜日の文字を中央、そのほかを左揃えなど
            Range("A2:G2").HorizontalAlignment = xlCenter
            Range("A2:G2").RowHeight = 25
            With Range("A3:G37")
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlBottom
                .ColumnWidth = 11.25
            End With
            
            MRow = 3
        End If

        '曜日を判定して列を決める
        If Weekday(SheetA.Cells(i, 1)) = 1 Then
            MCol = 7
        Else
            MCol = Weekday(SheetA.Cells(i, 1)) - 1
        End If
       
        '年間カレンダーの日付けと祝日をSheetBのセルに入れる
        SheetB.Cells(MRow, MCol) = _
            Day(SheetA.Cells(i, 1)) & " " & SheetA.Cells(i, 2)
               
'追加部分開始
        '年間カレンダーと月間カレンダーを同期する数式を入力
        For j = 1 To 4
            SheetB.Cells(MRow + j, MCol).Formula = _
                "=IF(ISBLANK('" & MyYear & "年カレンダー'!" & toA1("R" & i & "C" & j + 2) & _
                    "), " & Chr(34) & Chr(34) & ", '" & MyYear & "年カレンダー'!" & toA1("R" & i & "C" & j + 2) & ")"
        Next j
'追加部分終了

        '日付け文字スタイル
        With SheetB.Cells(MRow, MCol).Characters _
            (start:=1, Length:=Len(Day(SheetA.Cells(i, 1)))).Font
            .Name = "ＭＳ Ｐゴシック"
            .FontStyle = "標準"
            .Size = 17
            .ColorIndex = xlAutomatic
        End With
        '祝日の文字スタイル
        With SheetB.Cells(MRow, MCol).Characters _
            (start:=Len(Day(SheetA.Cells(i, 1))) + 2, _
            Length:=Len(SheetA.Cells(i, 2))).Font
            .Name = "ＭＳ Ｐゴシック"
            .FontStyle = "標準"
            .Size = 11
            .Subscript = True '下付き文字
            .ColorIndex = xlAutomatic
        End With
        'セルの塗りつぶし
        SheetB.Range(toA1("R" & MRow & "C" & MCol & ":R" & MRow + 4 & "C" & MCol)). _
            Interior.Color = SheetA.Cells(i, 1).Interior.Color
        If Weekday(SheetA.Cells(i + 1, 1)) = 2 Then
            MRow = MRow + 5
        End If
    Next i
End Sub

例えば、年間カレンダーの1月1日の行のC列に
「初詣」と入力すると
Vba20100326d

月間カレンダーの方もこうなります。
Vba20100326e

アプリケーション風味が少ししてきました。

2010年3月26日 (金) | | コメント (2) | トラックバック (0)

2010年3月24日 (水)

月間カレンダー、祝日あり

記事「祝日を年間カレンダーに追加する 」で作った
年間カレンダーを使って
月間カレンダーを作ります。

2010年分の年間カレンダーなら
「2010年カレンダー」というシート名になっていると思います。
このシートがないと下のコードはエラーになります。

少し長いコードなので
大体の説明だけします。

年間シートの日付けを上から順に
月間カレンダーにしていきます。

まず、月ごとにシートを挿入していくのですが
MyMonth と年間シートの日付けの月を比べて
等しくなかったらシートを挿入します。
シートを挿入したら
月、年、曜日、日ごとの枠を書きます。

年間シートの日付けは曜日を判定して列を決めて
次の日付けが月曜日なら次の週の行に移ります。

細かいことは、下のコードを標準モジュールにコピペして
知りたいプロパティなどにカーソルを持っていって
[F1]キーを押せば、
VBAヘルプの該当ページが開きますのでそれを見てください。

コードはこちら

月間カレンダー、祝日ありを作るコード：

Sub macro100324a()
'月間カレンダー
'1シートひと月

    Dim i, j, k As Integer
    Dim MyYear, MyMonth As Integer
    MyYear = 2010
    MyMonth = 0
    Dim SheetA, SheetB As Object
    Set SheetA = Sheets(MyYear & "年カレンダー")
    Dim MyRange As Range
    Dim StrWeekDay As Variant
    StrWeekDay = Array("月", "火", "水", "木", "金", "土", "日")
    Dim EndRow, MRow, MCol As Integer
    EndRow = SheetA.Range("A1").End(xlDown).Row
   
    For i = 2 To EndRow
        '月が替わったらシートを挿入
        If MyMonth <> Month(SheetA.Cells(i, 1)) Then
            MyMonth = Month(SheetA.Cells(i, 1))
            SheetAddDel (MyYear & "年" & MyMonth & "月")
            Set SheetB = Sheets(MyYear & "年" & MyMonth & "月")
            
            'なんとなくページ設定
            'まだよくわかってないけど
            With SheetB.PageSetup
                .PrintArea = "$A$1:$G$37"
                .Zoom = False
                .CenterHorizontally = True
                .PaperSize = xlPaperA4
                .FitToPagesTall = 1
                .FitToPagesWide = 1
            End With

            SheetB.Cells(1, 1) = MyMonth & "月"
            SheetB.Cells(1, 1).Font.Size = 24
            
            SheetB.Cells(1, 7) = MyYear & "年"
            SheetB.Cells(1, 7).Font.Size = 16
            
            For j = 1 To 7
                '曜日の文字を入れる
                Cells(2, j) = StrWeekDay(j - 1)
               
                '日ごとの枠を設定、6週分(固定)
                For k = 3 To 3 + 5 * 6 Step 5
                    Set MyRange = Range(toA1("R" & k & "C" & j & ":R" & k + 4 & "C" & j))
                    With MyRange.Borders(xlEdgeLeft)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With MyRange.Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With MyRange.Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With MyRange.Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                Next k
            Next j
            
            '曜日の文字を中央、そのほかを左揃えなど
            Range("A2:G2").HorizontalAlignment = xlCenter
            Range("A2:G2").RowHeight = 25
            With Range("A3:G37")
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlBottom
                .ColumnWidth = 11.25
            End With
            
            MRow = 3
        End If

        '曜日を判定して列を決める
        If Weekday(SheetA.Cells(i, 1)) = 1 Then
            MCol = 7
        Else
            MCol = Weekday(SheetA.Cells(i, 1)) - 1
        End If
       
        '年間カレンダーの日付けと祝日をSheetBのセルに入れる
        SheetB.Cells(MRow, MCol) = _
            Day(SheetA.Cells(i, 1)) & " " & SheetA.Cells(i, 2)
            
        '日付け文字スタイル
        With SheetB.Cells(MRow, MCol).Characters _
            (start:=1, Length:=Len(Day(SheetA.Cells(i, 1)))).Font
            .Name = "ＭＳ Ｐゴシック"
            .FontStyle = "標準"
            .Size = 17
            .ColorIndex = xlAutomatic
        End With
        '祝日の文字スタイル
        With SheetB.Cells(MRow, MCol).Characters _
            (start:=Len(Day(SheetA.Cells(i, 1))) + 2, _
            Length:=Len(SheetA.Cells(i, 2))).Font
            .Name = "ＭＳ Ｐゴシック"
            .FontStyle = "標準"
            .Size = 11
            .Subscript = True '下付き文字
            .ColorIndex = xlAutomatic
        End With
        'セルの塗りつぶし
        SheetB.Range(toA1("R" & MRow & "C" & MCol & ":R" & MRow + 4 & "C" & MCol)). _
            Interior.Color = SheetA.Cells(i, 1).Interior.Color
        If Weekday(SheetA.Cells(i + 1, 1)) = 2 Then
            MRow = MRow + 5
        End If
    Next i
End Sub

macro100324aを実行後のシートの一部(倍率50%)
Vba20100324a

祝日がある場合のセル
Vba20100324b

細かいとこはまだまだテキトーですが、
とりあえず月間カレンダーです。

2010年3月24日 (水) | | コメント (3) | トラックバック (0)

2010年3月23日 (火)

祝日を年間カレンダーに追加する

記事「任意の日付から任意の日付までを一列にセル に入れる 」の中の
DateWriterYプロシージャで作る年間カレンダーと、

記事「任意の年の祝日を取得する 」の中の
GetHollydaysプロシージャで取得する
祝日の情報を統合します。

手順は、
まず既存の２つのプロシージャを呼び出して
年間カレンダーと祝日の２つのシートを作成します。

この２つのシートの日付けが等しければ
祝日の名称を
年間カレンダーのシートにコピペします。

そして、その日付けのセルの塗りつぶしを
日曜と同じに色を設定します。

コードはこちら

祝日を年間カレンダーに追加するコード：

Sub macro100323a()
'2010年1列カレンダー
'祝日を追加

    Dim MyYear, EndRow1, EndRow2, FirstRow As Integer
    Dim SheetA, SheetB As Worksheet
    Dim i, j As Integer

    '既存プロシージャを呼び出し
    '年間カレンダー、祝日を取得
    MyYear = 2010
    Sheets.Add.Name = MyYear & "年カレンダー"
    Call DateWriterY(CStr(MyYear))
    Call GetHollydays(CStr(MyYear))
   
    'シートオブジェクトをセット
    Set SheetA = Sheets("祝日" & MyYear)
    Set SheetB = Sheets(MyYear & "年カレンダー")
   
    '各シートの最終行を代入
    EndRow1 = SheetA.Range("A1").End(xlDown).Row
    EndRow2 = SheetB.Range("A1").End(xlDown).Row
   
    '祝日を年間カレンダーに統合する
    FirstRow = 2
    For i = 3 To EndRow1
        For j = FirstRow To EndRow2
            If SheetA.Cells(i, 1) = SheetB.Cells(j, 1) Then
            'SheetAとSheetBの日付けが等しいなら
            '祝日名をコピペして、日付けを色付け
                SheetA.Cells(i, 2).Copy Destination:=SheetB.Cells(j, 2)
                SheetB.Cells(j, 1).Interior.ColorIndex = 38
                FirstRow = j + 1
                Exit For
            End If
        Next j
    Next i
            
End Sub

macro100323aを実行後のシートの一部
Vba20100323a

祝日も追加できたので
次は、ひと月を週ごとに区切った
よく見る月間カレンダーにしたいです。

2010年3月23日 (火) | | コメント (0) | トラックバック (0)

2010年3月22日 (月)

任意の年の祝日を取得する

大半の市販のカレンダーには
祝日の情報が載ってます。

祝日は、こちらのWebページで分かります。
国立天文台トップページ　＞ 暦計 算室　＞　暦要項

2010年3月22日現在では、
2004年から2011年までの国民の祝日が掲載されています。

このページをWebクエリでExcelに取り込んで
使いやすいように加工します。

手順は、まず
Webクエリで必要な表だけ
Excelのシートの適当な場所に取り込みます。

それから、A列に日付け、B列に名称をコピペし、
コピー元のWebクエリは削除します。

日付はWebクエリで取り込んだままだと
文字列のままだったので
ひと手間かけてDate型にしました。
方法は下のコードを見てください。

問題は、振替休日と国民の休日を加えることです。
それぞれ別にFor文を使って調べていって
振替休日と国民の休日を追加しています。

とりあえず2004年から2011年までは
正確に振替休日と国民の休日を追加できました。

下のコードのWebクエリの部分ですが
マクロ自動記録で記録したものを
一部分だけ替えてそのまま使ってあるので
必要性のないプロパティなどあるかと思います。

コードはこちら

祝日を取得するコード：

Sub macro100322a()
'GetHollydaysの使用例
'西暦4桁で年を指定する
    Call GetHollydays(2010)
End Sub

Sub GetHollydays(Year1 As Integer)
'祝日を取得する
'新しいシートを作成してwebからデータを取り込む
'Year1を西暦4桁で年を指定する

    With ActiveWorkbook.Worksheets
        .Add.Name = "祝日" + CStr(Year1)
    End With
    Range("A1").Value = Year1 & "年の国民の休日"
   
    Dim Year2 As String
    Year2 = Right(Year1, 2)
   
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://eco.mtk.nao.ac.jp/koyomi/yoko/" & Year1 & _
        "/rekiyou" & Year2 & "1.html", Destination:= _
        Range("D1"))
        .Name = "rekiyou091"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "1"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .Refresh BackgroundQuery:=False
    End With
   
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.nao.ac.jp/koyomi/yoko/" & Year1 & _
        "/rekiyou" & Year2 & "1.html", Destination:= _
        Range("G1"))
        .Name = "rekiyou091"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .Refresh BackgroundQuery:=False
    End With
   
    '適当なセルからコピペ
    Dim EndRow1, EndRow2 As Integer
    EndRow1 = Range("D1").End(xlDown).Row
    Range("D1:D" & EndRow1).Copy Range("B2")
    Range("E1:E" & EndRow1).Copy Range("A2")
    EndRow2 = Range("G1").End(xlDown).Row
    Range("G2:G" & EndRow2).Copy Range("B" & EndRow1 + 2)
    Range("H2:H" & EndRow2).Copy Range("A" & EndRow1 + 2)
    Range("D1:H9").Delete
   
    '表示形式を指定する
    Columns(1).NumberFormat = "m月d日(aaa)"

    '文字列の日付けをDate型にする
    Dim i As Integer
    For i = 3 To Range("A1").End(xlDown).Row
        Range("A" & i).FormulaR1C1 = Range("A" & i) & Year1 & "年"
    Next i
   
    '列幅自動調整
    Columns("A:B").EntireColumn.AutoFit
   
    '振替休日チェック
    Dim MyDate As Date
    Dim j As Integer
    j = 1
    For i = 3 To 25
    'Range("A" & i).Select
        If Weekday(Range("A" & i)) = 1 Then
            MyDate = Range("A" & i) + 1
Step1:
            If MyDate = Range("A" & i + j) Then
                MyDate = MyDate + 1
                j = j + 1
                GoTo Step1
            Else
                Rows(i + j).Insert shift:=xlShiftDown
                Range("A" & i + j) = MyDate
                Range("B" & i + j) = "振替休日"
                j = 1
            End If
        End If
    Next i
   
    '国民の休日チェック
    For i = 3 To 25
    'Range("A" & i).Select
        If Range("A" & i) = Range("A" & i + 1) - 2 Then
            MyDate = Range("A" & i) + 1
            If Weekday(MyDate) <> 1 Then
                Rows(i + 1).Insert shift:=xlShiftDown
                Range("A" & i + 1) = MyDate
                Range("B" & i + 1) = "国民の休日"
            End If
        End If
    Next i

End Sub

macro100322aを実行後のシート
Vba20100322a

今回は祝日を取得しただけですが
これを使ってカレンダーに祝日を組み込んでいきます。

2010年3月22日 (月) | | コメント (0) | トラックバック (0)

2010年3月20日 (土)

『Microsoft Excel 2000 Power Programming with VBA』

John Walkenbach (著)：Microsoft Excel 2000 Power Programming with VBA，1999

アマゾンで評価が良かったので買ってしまいました。
イミダス・現代用語並みの大きさと分厚さです。
目次を見た限りでは、
基本から発展までカバーしてそうです。

というのも、まだ目次しか読んでません…

いつも読みたいから本を買うんですけど
買ってすぐ読めない体質でして、
こちらの記事「田沼晴彦：『Excelで遊ぶ手作り数学シュミレーション』 」で、紹介した本も
１年はほったらかし。

今のところ、目次を見ただけのレビュー。

VBEのメニュー[挿入] で標準モジュールの下に
クラスモジュールとあるのですが、
クラスモジュールについてVBAのヘルプにも説明がほとんどなく
クラスモジュールについて書いてあるExcel VBAの本をずっと探してました。

で、クラスモジュールの説明があるかどうか
真っ先に見てみたのですが、
なんと
「Chapter 28:Understanding ClassModules」なる章が…

ありました。
この章、12ページあります。

いままで見たVBAに関する和書で
クラスモジュールについて書いてあるのを見たのは１回だけですが
それも何の説明もなく使われていて
ますますクラスモジュールの謎が深まっていたのですが
これで解決したらいいなと思います。

つづく…

2010年3月20日 (土) | | コメント (0) | トラックバック (0)

2010年3月19日 (金)

特定の曜日を判定してセルに色を付ける

記事「任意の日付から任意の日付までを一列にセル に入れる 」で、
日付を上から順に一列に入れました。

カレンダーやスケジュール帳など、
土曜日、日曜日は水色やピンクに色付けされています。
これをします。

曜日の判定にWeekday 関数を使います。
Weekday 関数は、日曜から順に1から7までの数字を返します。

日曜　　　1
月曜　　　2
火曜　　　3
水曜　　　4
木曜　　　5
金曜　　　6
土曜　　　7

使い方は、例えば

Weekday("2010/3/19")なら、金曜なので7を返します。

Weekday("2010/3/19") = 7

Weekday 関数は既定では、日曜から始まりますが
任意の曜日を最初にすることもできます。
詳細は、VBAヘルプにあります。

下のコードでは、範囲を指定して
その範囲の土日を判定して色付けます。

コードはこちら

土曜日曜のセルを色付けするコード：

Sub macro100319a()
'WeekendColor使用例
'括弧内、Rangeで範囲を指定する
    Call WeekendColor(Range("A2:A32"))
End Sub

Sub WeekendColor(MyRange As Range)
'土日に色づけ
    Dim obj As Object

    For Each obj In MyRange
        If Weekday(obj.Value) = 7 Then
        '土曜
            obj.Interior.ColorIndex = 37
        ElseIf Weekday(obj.Value) = 1 Then
        '日曜
            obj.Interior.ColorIndex = 38
        End If
    Next obj
End Sub

macro100319aを実行後のシートの一部
Vba20100319a

WeekendColorプロシージャはRange型で範囲を指定するので
一列だけではなく複数行でも大丈夫です。
Vba20100319b

これは、後々の為です。

記事「任意の日付から任意の日付までを一列にセル に入れる 」の中の
コード「DateWriter」を改造して
日付出力と同時に
土日の色付けもしてしまいます。

改造といっても
「WeekendColor」を呼び出すだけです。

DateWriterの中の変数SPANを使って
土日を判定して色を付ける範囲を指定します。

コードはこちら

土曜日曜を色付けする改造版DateWriter：

Sub DateWriter(DAY1 As Date, DAY2 As Date)
'任意の日付から任意の日付までを一列にセルに入れる
'土曜日曜を色付けする改造版DateWriter

    Cells(1, 1) = "日付"
    Dim i, SPAN As Integer
   
    SPAN = DAY2 - DAY1 + 1 '日数
    Debug.Print SPAN
    For i = 0 To SPAN - 1
        Cells(i + 2, 1) = DAY1 + i
    Next i
   
    'ここにWeekendColorを追加
    Call WeekendColor(Range("A2:A" & SPAN - 1))
   
    '表示形式を指定する
    Columns(1).NumberFormat = "m月d日(aaa)"

End Sub

カレンダー道は、まだまだ続く。

2010年3月19日 (金) | | コメント (0) | トラックバック (0)

2010年3月18日 (木)

任意の日付から任意の日付までを一列にセルに入れる

２つの任意の日を早い順からそれぞれ
DAY1、DAY2とします。

DAY2 - DAY1 + 1

で2つの日付の間の日数がわかります。
これをSPANとします。
つまり、

SPAN = DAY2 - DAY1 + 1

次に日付をセルに入れていきます。
一番最初のセル（下のコードではセルA2）に
DAY1を入れます。
以下、1つ下のセルA3では

DAY1 + 0

の値を入れます。

下に向かって順番に

DAY1 + 1
DAY1 + 2
DAY1 + 3
…
DAY1 + SPAN

のように入れていきます。
DAY1 + SPAN = DAY2です。

これをするのにFor文を使います。

For　i = 0 to SPAN - 1
　　　…
Next i

のようにします。
日時の計算については、
こちらの記事「日時と時間」を参考してみてください。

任意の日付から任意の日付までを一列にセル に入れるコード：

Sub macro100318a()
'DateWriterの使用例
    Sheets.Add
    Call DateWriter("2010/3/13", "2010/3/18")
End Sub

Sub DateWriter(DAY1 As Date, DAY2 As Date)
'任意の日付から任意の日付までを一列にセルに入れる
    Cells(1, 1) = "日付"
    Dim i, SPAN As Integer
   
    SPAN = DAY2 - DAY1 + 1 '日数
    Debug.Print SPAN
    For i = 0 To SPAN - 1
        Cells(i + 2, 1) = DAY1 + i
    Next i
   
    '表示形式を指定する
    Columns(1).NumberFormat = "m月d日(aaa)"

End Sub

macro100318aを実行後のシートの状態
Vba20100318a

WriteDaterを使って、任意の年の1年間の日付を出力する
WriteDaterYプロシージャを作ります。

仕組みはコードを見れば分かると思います。

コードはこちら

年間カレンダーを作るコード：

Sub macro100318b()
'DateWriterYの使用例
'2010年1列カレンダー
'括弧の中に任意の年を入れる(4桁西暦)
    Sheets.Add
    Call DateWriterY(2010)
End Sub

Sub DateWriterY(MyYear As Integer)
'DateWriterを使って
'年間1列カレンダーを作る

    Call DateWriter(MyYear & "/1/1", MyYear & "/12/31")
   
End Sub

さて、年間ときたら次は月間カレンダーです。

月によって日数が違うので
月末の日付を求めるの必要があります。

これには、DateAdd 関数を使います。
詳しい説明はVBAヘルプにあります。

下のコードでは、指定した月の１日に
一ヶ月を足して1日分引いて
指定した月の月末の日付を求めています。

月間カレンダーを作るコード：

Sub macro100318c()
'DateWriterMの使用例
'月間1列カレンダー
'括弧の中に任意の年、月を入れる
    Sheets.Add
    Call DateWriterM(2010, 5)
End Sub

Sub DateWriterM(MyYear As Integer, MyMonth As Integer)
'DateWriterを使って
'月間1列カレンダーを作る
    Dim DAY1, DAY2 As Date
    DAY1 = MyYear & "/" & MyMonth & "/01"
    DAY2 = DateAdd("m", 1, DAY1) - 1

    Call DateWriter(CDate(DAY1), DAY2)
   
End Sub

DAY1はDate型で宣言したのですが
WriteDaterMに入れる時、そのままでは型が違ってエラーになったので
Date型に変換しています。

たまに、こういうことがあります。
現在のところ、理由は不明。

2010年3月18日 (木) | | コメント (0) | トラックバック (0)

2010年3月17日 (水)

シート名を検索、条件を満たしたシートを削除

記事「シート挿入あれこれ 3 」では、
macro103016a、macro103016a2、macro103016a3、macro103016a4、…
と番号を付けてシートを挿入していきました。

今度は、逆に
シート名に文字列"macro103016a"を含むシートを削除します。

シート名の検索には、 If文とLike演算子を組み合わせて使います。

"macro100316a*"

のようにワイルドカードを使います。

下のコードでは、
shname = "macro100316a"でシート名に含まれる文字列を指定して、
あとから「& "*"」として
ワイルドカードを文字列に加えて使っています。

コードはこちら

シート名を検索、条件に合えば削除するコード：

Sub macro100317a()
'現在のWorkbookに
'"macro100316a*"の条件に合うSheetがないか調べる。
'あれば、削除する
   
    Dim sh As Worksheet
    Dim shname As String
    shname = "macro100316a"
   
    For Each sh In Worksheets
        If sh.Name Like shname & "*" Then
            Application.DisplayAlerts = False
            sh.Delete
            Application.DisplayAlerts = True
        End If
    Next sh
   
End Sub

Like演算子は、*のほかにも?や#なども使えます。

?は任意の１文字、#は任意の1文字の数字を表します。

VBAヘルプのLike演算子の頁に
*、?、#の詳しい説明があります。

2010年3月17日 (水) | | コメント (0) | トラックバック (0)

2010年3月16日 (火)

シート挿入あれこれ 3

記事「シート挿入あれこれ 2 」のつづき…

記事「シート挿入あれこれ 」のなかで
シートの挿入方法について
次の4通りを考えました。

１．既存シートを削除した上で、新たに同名のシートを挿入する。
２．既存シートの全セルを削除して、新たにシートを挿入しない。
３．既存シートの名前を変更して残し、新たにシートを挿入する。
４．既存シートをそのまま残し、
　　新たに挿入するシートの名前に番号を付けていく。

ここでは、
４．既存シートをそのまま残し、
　　新たに挿入するシートの名前に番号を付けていく。
についてVBAでやってみます。

手順は、まず
shnameで指定した名前と一致するシートがあるか調べます。
あれば、shnameに番号を付けて、shnameを変更します。

番号を付けて変更したshnameと
名前が一致するシートがあるかどうか調べるために
For Each...Next ステートメントの前まで戻ります。

再度、番号を付けて変更したshnameと一致するシートがあれば
番号を１つ大きくしてshnameを変更します。

これを、名前がshnameと一致するシートがなくなるまで繰り返します。
最後に名前をshnameにしてシートを挿入します。

コードはこちら

同名シートが在れば番号をふって新たにシートを挿入 するコード：

Sub macro100316a()
'SheetAddCNameの使用例
    SheetAddCName ("macro100316a")
End Sub

Sub SheetAddCName(shname As String)
'現在のWorkbookに同名 のSheetがないか確認する。
'あれば、新しいSheetに番号を付けて挿入する
   
    Dim sh As Object
    Dim shname2 As String
    Dim num, NameLen As Integer
    NameLen = Len(shname)
    num = 2
    
Step1:
    For Each sh In Worksheets
        If sh.Name = shname Then
            shname = Left(shname, NameLen) & num
            num = num + 1
            GoTo Step1
        End If
    Next sh
   
    'シートを挿入
    Sheets.Add.Name = shname

End Sub

シートmacro100316aがない状態から
macro100316aを数回実行した状態が下の画像です。
Vba20100316a_2

Len関数、Left関数の説明はVBAヘルプにあります。

2010年3月16日 (火) | | コメント (0)

2010年3月15日 (月)

シート挿入あれこれ 2

記事「シート挿入あれこれ 」のつづき…

上記記事のなかで
シートの挿入方法について
次の4通りを考えました。

１．既存シートを削除した上で、新たに同名のシートを挿入する。
２．既存シートの全セルを削除して、新たにシートを挿入しない。
３．既存シートの名前を変更して残し、新たにシートを挿入する。
４．既存シートをそのまま残し、
　　新たに挿入するシートの名前に番号を付けていく。

ここでは、
３．既存シートの名前を変更して残し、新たにシートを挿入する。
についてVBAでやってみます。

「既存シートの名前を変更して残し」の部分についてですが
単純に数字を付けて名前を変更します。

手動で既存のシートをコピーすると
括弧つきで数字がつけられます。

手動でシートをコピーする手順は、
まず、シートのタブのところで右クリック。

Vba20100315a
[移動またはコピー]を選択すると次のダイアログがでる。

Vba20100315b
[コピーを作成する]にチェックをいれOKボタンを押す。

Vba20100315c
この画像は「Sheet1」を3回コピーした状態です。
(2)、(3)、(4)と番号が付けられます。

これは、VBAで既存のシートを同一ワークブックにコピーしたときも
同じです。

ナンバリングを自分でしてもいいのですが
めんどくさいので
とりあえずエクセルちゃんにナンバリングしてもらいます。

手順は、既存のシートをコピーして
Excelに自動で数字を付けてもらって前のシートの名前を変更する。
残ったシートは削除して、新たに同名のシートを追加する。

コードはこちら

既存シートを残して新たにシートを挿入するコード：

Sub macro100315a()
'SheetAddCNameCopyの使用例
    SheetAddCNameCopy ("macro100315a")
End Sub

Sub SheetAddCNameCopy(shname As String)
'現在のWorkbookに同名のSheetがないか確認する。
'あれば、そのSheetをコピーして
'Excelに自動で番号を付けてもらって残す。
'それから削除、新しいSheetを挿入する
   
    Dim sh As Object
   
    For Each sh In Worksheets
        If sh.Name = shname Then
            'シートshnameの後ろにコピーしたシートを挿入
            Sheets(shname).Copy after:=Sheets(shname)
            'シートを削除
            Application.DisplayAlerts = False
            Sheets(shname).Delete
            Application.DisplayAlerts = True
        End If
    Next sh
   
    'シートを挿入
    Sheets.Add.Name = shname

End Sub

シートmacro100315aがない状態から
macro100315aを4回実行した状態が下の画像です。
Vba20100315d

３．でシートを「削除する」としてしまったけど、
シートの全セルを削除して白紙状態にしてもいいと思います。

つづく

2010年3月15日 (月) | | コメント (0) | トラックバック (0)

2010年3月14日 (日)

シート挿入あれこれ

シートを名前を付けて挿入するには

Sheets.Add.Name = "シートの名前"

とします。

このとき、同名のシートが存在したら
次のようなエラーになります。
Vba20100314a

このエラーを避けるために
指定した名前のシートが存在するか確かめます。
で、もし同じ名前のシートがあった場合、
どうするか？ですが、

１．既存シートを削除した上で、新たに同名のシートを挿入する。
２．既存シートの全セルを削除して、新たにシートを挿入しない。
３．既存シートの名前を変更して残し、新たにシートを挿入する。
４．既存シートをそのまま残し、
　　新たに挿入するシートの名前に番号を付けていく。

といった方法が考えられると思います。
順番にやっていきたいと思います。

まず、
１．既存シートを削除した上で、新たに同名のシートを挿入する。
についてです。

For Each...Next ステートメントですべてのシートの名前を調べていき
指定した名前と同じシートが在れば、削除します。
なければ何もしません。
同名のシートが在ってもなくてもプロシージャの最後で
shnameで指定した名前のシートを削除します。

コードはこちら

同名のシートがあれば削除して新たに挿入するコード：

Sub macro100314a()
'SheetAddDelの使用例
    SheetAddDel ("macro100314a")
End Sub

Sub SheetAddDel(shname As String)
'現在のWorkbookに同名のSheetがないか確認する。
'あれば、そのSheetを削除する。
'それから、新しいSheetを挿入する
   
    Dim sh As Object
   
    For Each sh In Worksheets
        If sh.Name = shname Then
            Application.DisplayAlerts = False
            sh.Delete
            Application.DisplayAlerts = True
        End If
    Next sh
   
    Sheets.Add.Name = shname

End Sub

次に、
２．既存シートの全セルを削除して、新たにシートを挿入しない。
についてです。

１．のコードを少し変えただけです。

同名のシートがあった場合、
１．のコードではシートを削除しているところを
シートの全セルを削除するに変更して、
プロシージャを終える。

同名のシートがなければ、単純にシートを挿入するだけです。

コードはこちら

同名のシートがあればセルを削除して新たに挿入しない コード：

Sub macro100314b()
'SheetAddCDelの使用例
    SheetAddCDel ("macro100314b")
End Sub

Sub SheetAddCDel(shname As String)
'現在のWorkbookに同名のSheetがないか確認する。
'あれば、そのSheetの全セルを削除する。
'それから、新しいSheetを挿入する
   
    Dim sh As Object
   
    For Each sh In Worksheets
        If sh.Name = shname Then
            Application.DisplayAlerts = False
            sh.Cells.Delete
            Application.DisplayAlerts = True
            Exit Sub
        End If
    Next sh
   
    Sheets.Add.Name = shname

End Sub

つづく

2010年3月14日 (日) | | コメント (0) | トラックバック (0)

2010年3月13日 (土)

指定したシートがあるか確認してからそのシートを削除する

VBAでシートを指定して削除しようとしたときに
そのシートがなかったら
このようなエラーになります。
Vba20100313a

このようなエラーを発生させないために
まず、指定したシートが存在するか確認してから
そのシートを削除するプロシージャを作ってみます。

指定したシートが存在するか確認する方法は
アクティブなワークブックのすべてのシートの名前と
指定したシートの名前が一致するかをIf文で調べます。

もし指定したシートが存在したら
そのシートを削除してSheetDelプロシージャ（下にある）を終了します。

すべてのシートを調べても
指定したシートがなかった場合、
「シート"指定したシートの名前"はありません。」
とメッセージを表示します。

macro100313aは、コードの中で使うシートを挿入します。
macro100313bの中で、SheetDelプロシージャを使っています。

存在を確認してからシートを削除するコード：

Sub macro100313b()
'SheetDelの使い方
'（）内に文字列でシート名を指定する

    SheetDel ("macro100313a")
   
End Sub

Sub macro100313a()
'シート"macro100313a"の挿入

    Sheets.Add.Name = "macro100313a"
   
End Sub

Sub SheetDel(shname As String)
'ActiveなWorkbookに
'shnameで指定した名前のSheetが存在するか確認してから
'そのsheetを削除する
'なければそのようにメッセージする
   
    Dim sh As Worksheet
   
    For Each sh In Worksheets
        If sh.Name = shname Then
        'Sheetが存在する場合
            Application.DisplayAlerts = False
            sh.Delete
            Application.DisplayAlerts = True
            Exit Sub
        End If
    Next sh
   
    'Sheetがなかった場合
    MsgBox "シート" & Chr(34) & shname & _
        Chr(34) & "はありません。"
       
End Sub

指定したシートがなかった場合のダイアログです。
Vba20100313b

「For Each sh In Worksheets」の部分は、
Worksheets プロパティに入っている
すべてのワークシートを表す Sheets コレクションの中から
一つずつ変数shに入れています。

ワークブックの中のあるシートを返す変数shを使って、
ワークブックの中のあるシートの名前をsh.nameで取得してます。

2010年3月13日 (土) | | コメント (0) | トラックバック (0)

2010年3月12日 (金)

VBAで警告なしにシートを削除する

VBAでシートを削除するには、

Sheets("シートの名前").Delete

とします。
しかし、これには問題があります。
試しに、下のコードを実行してみます。

シートを挿入して、名前をつける。
そして、それを削除する。
っといった
元の木阿弥状態なコードです。

シートを削除するコード：

Sub macro100312a()
'シートを削除する
    Sheets.Add.Name = "macro100312a"
    Sheets("macro100312a").Delete
End Sub

実行すると、このような警告のダイアログがでます。

Vba20100312a

このダイアログは、
手動でシートを削除しようとするときもでます。

シートを削除するたびに
この警告のダイアログが出ていては、
いちいちOKボタンを押さないと進めないので
この警告のダイアログを出さないようにします。

そのために、DisplayAlerts プロパティを使います。
使い方は、下のコードを参考にしてください。

Application.DisplayAlerts = Falseと
Application.DisplayAlerts = Trueの間で
警告のダイアログが出なくなります。

個人的にApplication.DisplayAlerts = Falseと
Application.DisplayAlerts = Trueの間はインデントしてますが、
この記述方法がVBA界の一般常識かはわかりません。

警告なしにシートを削除するコード：

Sub macro100312b()
'警告なしにシートを削除する
    Application.DisplayAlerts = False
        Sheets.Add.Name = "macro100312b"
        Sheets("macro100312b").Delete
    Application.DisplayAlerts = True
End Sub

Application.DisplayAlerts = Falseだけでも
プロシージャが終了すれば
Application.DisplayAlerts = True状態に戻ります。

2010年3月12日 (金) | | コメント (0) | トラックバック (0)

2010年3月 9日 (火)

列を表す英文字を列番号に変換

記事「列番号を 英文字に変換してRangeプロパティに使う 」
では、列番号を英文字に変換しました。

今回は、その逆で
英文字を列番号に変換します。

仕組みは、
10進数を2進数に変換する要領です。

列を表す英文字を列番号に変換するコード：

Sub macro100309a()
'列を表す英文字を列番号に変換
    Dim i, IntColumn, ChrNum As Integer
    Dim StrColumn As String
    '変換したい英文字を設定(大文字で)
    StrColumn = "CD"
    For i = 0 To Len(StrColumn) - 1
        ChrNum = Asc(Mid(StrColumn, Len(StrColumn) - i, 1)) - 64
        IntColumn = IntColumn + 26 ^ i * ChrNum
    Next i
    MsgBox StrColumn & " = " & IntColumn
End Sub

変換後の列番号をMsgBoxで表示する。
Vba20100309a

アルファベットは26文字なので26進数になります。
Aが1、Bが2、Cが3、…、Zが26になるのは簡単に分かります。

"CD"を番号にする場合を説明します。
Cは3、Dは4です。
Cは2桁目なので、3 * 26^1= 78
Dは1桁目なので、4 * 26 ^ 0 = 4
78 + 4 = 82
よって、英文字"CD"は、列番号82になります。

アルファベットを数字に変換するのに
Asc関数を使います。

Asc("A") = 65
Asc("B") = 66
…
Asc("Z") = 90

Asc関数は以上のようにAからZまでで、
65から90までの数字を返します。（大文字で）

Aを１に変換するには
Asc("A") - 64 = 1
のように64を引きます。
他のアルファベットも同様です。

このアルファベットを変換した数字を使って
26進数である英文字を上で説明したように
10進数に変換します。

コードの中に出てくる関数の説明はVBAヘルプにあります。

2010年3月 9日 (火) | | コメント (0) | トラックバック (0)

2010年3月 8日 (月)

VBAでファイルの存在を確認してから開く

VBAでブックを開くときは

Workbooks.Open "ファイルまでのパス"

とします。

例えば、下のコードで
指定したファイルが存在しない場合
エラーになります。

ブックを開くコード：

Sub macro100308a()
'ファイルを開く
    Workbooks.Open "C:\abc.xls"
End Sub

エラーのダイアログはこうです。
Vba20100308a

エラーが起こってから処理するよりも
エラーが起こらないようにするのがいいプログラムのようなので
エラーをできるだけ起こさないようにしたいと思います。

上記のエラーを起こさないように
指定したファイルが存在しているか確かめてから
ブックを開くようにします。

次のコードは、
MyPathで開きたいファイルがあるフォルダまでのパスを、
MyFileで開きたいファイルを指定します。

ファイルの存在を確かめるのに、FileSearchを使います。
条件分岐Ifを使って、
存在していたら開く
存在していなかったら開かないようにします。

コードはこちら

存在を確かめてブックを開くコード：

Sub macro100308b()
'存在を確認してからファイルを開く

    Dim MyPath, MyFile As String
    Dim i As Integer
    '任意のフォルダまでのパス
    MyPath = "C:\"
    '任意のファイル名
    MyFile = "abc.xls"
       
        With Application.FileSearch
            .LookIn = MyPath
            .Filename = MyFile
            If .Execute() = 1 Then
            'ブックが存在する場合
                Workbooks.Open MyFile
            Else
            'ブックが存在しない場合
                MsgBox "指定したファイルがありません。"
            End If
        End With

End Sub

条件分岐Ifの中の処理を変えれば
違った処理にも応用できます。

2010年3月 8日 (月) | | コメント (0) | トラックバック (0)

2010年3月 7日 (日)

ファイルの名前を変更する

VBAでファイルの名前を変更するには
Nameステートメントを使います。
使い方は、

Name OldName As NewName

のOldNameに名前を変更したいファイルのフルパスを入れ、
NewNameに名前を変更した後のフルパスを入れます。

サンプルコードはこちら
下のコードはMyPathで指定したフォルダ内にあるファイル
test.textをAfter_test.txtというファイル名に変更します。

ファイル名を変更するコード：

Sub macro100307a()
'ファイル名を変更する

    Dim MyPath, MyFile As String
    Dim OldName, NewName As String
    MyPath = "任意のフォルダへのパス(最後に\までつける)"
    OldName = MyPath & "test.txt"
    NewName = MyPath & "After_test.txt"
    'ファイル名を変更
    Name OldName As NewName
   
End Sub

Nameステートメントはファイル名だけでなく
フォルダ名も変更できます。

下のコードは、
MyPathで指定したフォルダの中の
testfolderという名前のフォルダーを
After_testfolderという名前にフォルダ名を変更します。

フォルダ名を変更するコード：

Sub macro100307b()
'フォルダ名を変更する

    Dim MyPath, MyFile As String
    Dim OldName, NewName As String
    MyPath = "任意のフォルダへのパス(最後に\までつける)"
    OldName = MyPath & "testfolder"
    NewName = MyPath & "After_testfolder"
    'ファイル名を変更
    Name OldName As NewName
   
End Sub

次にある条件のファイルを検索して
その条件を満たすファイル名を変更するコードです。

MyPathで名前を変更したいファイルがあるフォルダまでのパスを指定します。
このコードでは、区切りの\まで付けて指定してください。

検索条件のところ「*.*」は、
指定したフォルダ内のすべてのファイルにマッチします。

下のコードは、指定したフォルダ内のすべてのファイルの名前の前に
「2009」を付け足します。

ファイルを検索してファイル名を変更するコード：

Sub macro100307c()
'ファイル名を変更する
    Dim MyPath, MyFile As String
    Dim OldName, NewName As String
    Dim i As Integer

    MyPath = "任意のフォルダへのパス(最後に\までつける)"
        'ファイルの有無を確認
        With Application.FileSearch
            .LookIn = MyPath
            .Filename = "*.*" 'すべてのファイル
            If .Execute() > 0 Then
                MsgBox .FoundFiles.count & _
                    " 個のファイルが見つかりました。"
                For i = 1 To .FoundFiles.count
                    MyFile = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Len(MyPath))
                    OldName = .FoundFiles(i)
                    NewName = MyPath & "2009" & MyFile
                    'ファイル名を変更
                    Name OldName As NewName
                Next i
            Else
                MsgBox "検索条件を満たすファイルはありません。"
            End If
        End With
End Sub

目的に合うよう、検索条件など変更して使えば、
大量のファイルの名前を変更するのが楽です。

2010年3月 7日 (日) | | コメント (0) | トラックバック (0)

2010年3月 5日 (金)

VBAでファイルを削除する

記事「ワイルドカードで検索してファイル名を取得 」
のなかのコードを改造してコピーしたファイルを削除します。

あるファイルに大きな変更を加える前とかに
変更前に戻れるように複製を作っておきます。
このようなことが何回かあると複製がたくさんになります。

上のような場合、ファイル単位のバックアップなんかは
そのファイルの複製を作って済ませたりします。

フォルダエクスプローラーで
あるファイルを選択して同じフォルダにコピーすると
「コピー 」が元のファイル名の前に足したファイル名になります。
2つ目、3つ目のファイルのコピーは、
「コピー (2)」「コピー (3)」と数字が付け足されます。
Vba20100305a

これを利用してコピーしたファイルを削除します。

具体的には、MyPathで指定したフォルダ内を
ワイルドカードを使って「コピー*」で検索して
検索条件を満たしたファイルを削除します。

削除するにはKillステートメントを使います。

記事「ワイルドカードで検索してファイル名を取得 」の中のコードでは
検索条件を満たしたファイルの名前をシートに書き出しました。
ここでは、この箇所を
Cells(i + 1, 1) = .FoundFiles(i)から

Kill .FoundFiles(i)

に替えます。

枠内のコードは、基本的に
Excelの標準モジュールにコピペして
そのまま実行できるようになっています。

Killステートメントは、
シートなどの削除と違って警告が出ません。
大事なファイルを削除しないよう気をつけてください。

下のコードでは念の為
Killステートメントの前に
Stopをつけてあります。

ワイルドカードで検索してファイル名を取得するコード：

Sub macro100305a()
'ファイルを削除する
    Dim MyPath, MyFile As String
    Dim i As Integer

    MyPath = "C:\Documents and Settings\" & _
        "あなたのユーザー名\My Documents\"
        'ファイルの有無を確認
        With Application.FileSearch
            .LookIn = MyPath
            .Filename = "コピー*"
            If .Execute() > 0 Then
                MsgBox .FoundFiles.count & _
                    " 個のファイルが見つかりました。"
                For i = 1 To .FoundFiles.count
                    Debug.Print .FoundFiles(i)
                    Stop
                    'Killは警告なくファイルを削除します。
                    '実行を続けるにはよく確認してください。
                    '念の為Stopしました。
                    '複製しておいたファイルを削除
                    Kill .FoundFiles(i)
                Next i
            Else
                MsgBox "検索条件を満たすファイルはありません。"
            End If
        End With
End Sub

くれぐれも
大事なファイルを削除しないよう気をつけてください。

2010年3月 5日 (金) | | コメント (0) | トラックバック (0)

ワイルドカードで検索してファイル名を取得

VBAでファイルを検索するときは
FileSearchオブジェクトを使います。

下のコードは
マイドキュメントのフォルダ内の拡張子.xls
つまりExcelのファイルを検索して
検索結果をシートに書き出します。

変数MyPathの文字列内の
「あなたのユーザー名」のところを適宜変更してください。

ファイルの検索にワイルドカード（*）を使います。

.Filename = "*.xls"

の"*.xls"の箇所の拡張子を換えれば
その拡張子が検索できます。
また、
MyPathを検索したいフォルダへのパスに変更すれば
そのフォルダを検索できます。

このコードでは、For文のなかで
検索結果のファイル名を
シートに書き出す操作をしています。

ここを変更すれば検索結果のファイルに対して
いろいろな操作ができます。

ワイルドカードで検索してファイル名を取得するコード：

Sub macro100304a()
'ファイル名を取得
'ワイルドカードで検索
    Sheets.Add
    Dim MyPath, MyFile As String
    Dim i As Integer
    'マイドキュメント内を検索
    MyPath = "C:\Documents and Settings\" & _
        "あなたのユーザー名\My Documents\"
        'ファイルの有無を確認
        With Application.FileSearch
            'MyPathで指定したフォルダ内を検索する
            .LookIn = MyPath
            '拡張子xlsのファイルを検索
            .Filename = "*.xls"
            If .Execute() > 0 Then
                Cells(1, 1) = .FoundFiles.count & _
                    " 個のファイルが見つかりました。"
                For i = 1 To .FoundFiles.count
                    '見つかったファイルに対する操作
                    'ここでは、パスをセルに入れる
                    Cells(i + 1, 1) = .FoundFiles(i)
                 Next i
            Else
                Cells(1, 1) = "検索条件を満たすファイルはありません。"
            End If
        End With
End Sub

実行後のシートの具体例
Vba20100304a

1行目にファイルの数、2行目以降ファイル名が続きます。
ファイル名といってもフルパスです。
ファイル名だけにするには、
MyPathで指定したフォルダの部分以降を取得します。

それには、Right関数とLen関数を使います。
それぞれの関数の説明はVBAヘルプにあります。

使い方は具体例を挙げます。

Right("やむえむのExcel VBAメモ", 5)

は、右から5文字の「VBAメモ」を返します。

Len("やむえむのExcel VBAメモ"）

は、文字列の文字数の16を返します。

これを使ってフォルダの部分以降のファイル名を取得するには、
上記コードの「Cells(i + 1, 1) = .FoundFiles(i)」の部分の右辺を

Right(.FoundFiles(i), Len(.FoundFiles(i)) - Len(MyPath))

に変更します。

2010年3月 5日 (金) | | コメント (0) | トラックバック (0)

2010年3月 3日 (水)

コピーしてコピーしたセルを挿入する

コピーしたセルをペーストするとき
既存のデータの後（下）に追加する場合は
そのままペーストすればいいのですが
既存のデータの前にコピーしたセルを入れたい時
セルを挿入してペーストします。

例えば、時系列のデータを順次コピペするような場合を想定すると
上から下へ古いのから新しいのまで並べる方法と
下から上へ古いのから新しいのまで並べる方法が
あると思います。

後者の方で新しいデータを上へ追加していくときに
コピー、セルを挿入、ペーストを使います。

手動でこの操作を行うには
まず、ある範囲を選択して、コピーします。
次に適当なセルで右クリックすると次のようなメニューが現れます。

Vba20100303a

[コピーしたセルを挿入]を選ぶと
セルを挿入してペーストするのを一気にできます。

コピーしたセルを挿入するサンプルコード：
Sub macro100303a()
'コピーしてコピーしたセルを挿入する例
   
    '1行5列の範囲をコピー
    Sheets("Sheet1").Range("AA1:AE1").Copy
    'シフト方向は、下へずれるならxlDown
    '右へずれるならxlToRight
    Sheets("Sheet2").Range("A1").Insert Shift:=xlDown
    Application.CutCopyMode = False
End Sub

データを下に下に追加していく場合は
最終行を求めるための手間が掛かり、
またペーストの位置を指定するために
変数を使用しなければいけないですが、

データを上に上に追加していく場合は
コピーする範囲の形が同じ（例えば、1行6列とか）なら
変数を使って範囲を指定する必要がないので
簡単です。

2010年3月 3日 (水) | | コメント (0) | トラックバック (0)

2010年3月 2日 (火)

列番号を英文字に変換してRangeプロパティに使う

2つの変数、例えば i と ｊ などで
For文を使ってセルを指定したいとき
Rangeプロパティのみ対応していて
Cells( i, j )ではできないプロパティがあるので
少し手間が必要です。

なぜなら、
Ragneプロパティは、A1形式にしか対応してないからです。
2つの変数 i、ｊ を使ってA1形式にする必要があります。

マイクロソフトサポートオンラインで次の頁がありましたので

Excel で列番号を英文字に変換する 方法

この頁の
ConvertToLetterファンクションプロシージャを使ってやってみます。

列番号を英文字に変換するしくみについては
この頁で具体例を挙げて説明されています。
Chr関数のアルファベットなんて使う時ないな～
なんて思ってましたが
こういうときに使うんですね。

列番号を英数字にするしくみは
要するにアルファベットは全部で26文字なので
26進数ですね。

26までは、普通にAからZまでで
27なったら1つ繰り上がってAA
28から52まではABからAZ、
53 (=26*2+1)になったらまた繰り上がってBA
…
というふうです。

次のコードは、
ConvertToLetterファンクションプロシージャを
標準モジュールにコピペしてから実行してください。

列番号を英数字に変換してRangeプロパティに使うコード：

Sub macro100302a()
'列番号を英数字に変換してRangeプロパティに使う

    Sheets.Add
    Dim i, j As Integer
    For i = 1 To 100
        For j = 1 To 100
            'Rangeプロパティに使う
            Range(ConvertToLetter(j) & i) = ConvertToLetter(j) & i
        Next j
    Next i
End Sub

実行後のシートの一部
Vba20100302a

単純にセルにA1形式の文字列を入れただけです。

R1C１形式をRangeプロパティに使いたいときは
記事「R1C1形 式をA1形式に変換する」
を参考にしてください。

2010年3月 2日 (火) | | コメント (0) | トラックバック (0)

2010年3月 1日 (月)

VBAでセルの高さと幅を自動調節する

手動で、セルの高さと幅を自動調節するには
セルとセルの境界線にマウスのカーソルを移動させ
下の画像のカーソルになったらダブルクリックします。

例えば、
A列を自動調整したい場合は
A列とB列の間の境界線をダブルクリックします。
Vba20100301a

1行目の高さを自動調整したい場合は
1行目と2行目の間の境界線をダブルクリックします。
Vba20100301b

VBAで自動調節するときは
AutFit メソッドを使います。
とりわけ説明することもないので
そのままコードを羅列します。

列幅を自動調整するコード：

Sub macro100301a()
'列幅を自動調整する
    Columns("A").AutoFit
End Sub

いちいち範囲を指定するのがめんどくさいような、
１回だけの作業ならこれでもいいのではないでしょうか。

すべての列幅を自動調整するコード：

Sub macro100301b()
'すべての列幅を自動調整する
    Columns.AutoFit
End Sub

行の自動調整も同様です。

行高さを自動調整するコード：

Sub macro100301c()
'行高さを自動調整する
    Rows(1).AutoFit
End Sub

すべての行高さを自動調整するコード：

Sub macro100301d()
'すべての行高さを自動調整する
    Rows.AutoFit
End Sub

次に、Rangeを使って範囲を指定します。

Range("A1:C3").AutoFit

で実行すると次のようなエラーになります。
Vba20100301c

正しくは次のコードのようにしてください。

Rangeを使ってセルの高さ幅を自動調整するコード：

Sub macro100301e()
'Rangeを使って
'高さと幅を自動調整する
    Range("A1:C5").Rows.AutoFit
    Range("A1:C5").Columns.AutoFit
End Sub

最後に、UsedRangeを使って
使用しているセルの高さ幅の自動調整をします。

UsedRangeを使ってセルの高さ幅を自動調整するコード：

Sub macro100301f()
'使っているセルの高さと幅を自動調整する
    With ActiveSheet.UsedRange
        .Rows.AutoFit
        .Columns.AutoFit
    End With
End Sub

実行前のシートの状態
Vba20100301d

実行後のシートの状態
Vba20100301e

使用しているRange("A1:D4")の範囲のセルの
高さと幅が自動調整されました。

2010年3月 1日 (月) | | コメント (0) | トラックバック (0)

« 2010年2月 | トップページ | 2010年4月 »