カテゴリー別アーカイブ: Excel

[Excel][VBA] VBAでテキストデータを出力する

VBAでエクセルの内容を処理し、テキストデータとしてアウトプットする。

例として以下のようなエクセルのファイルをよういする。

これをA1:B10の範囲でCSVとしてアウトプットする。

Sub CSV_OUTPUT()

    fnsave = "d:\work\出力結果.txt" 'アウトプットの場所
    numff = FreeFile
    Open fnsave For Output As #numff
    
    temp = ""
    For i = 1 To 10
        '各セルをカンマ、改行文字を間に挟みながら、
        '一つの文字列として連結する
        temp = temp & Cells(i, 1) & "," Cells(i, 1) &char(13) & char(10)
    Next i

    '文字列をファイルに出力する。
    Print #numff, temp

    Close #numff
    
End Sub

出力結果は以下のようになる。

1,aaa
2,bbb
3,ccc
4,ddd
5,eee
6,fff
7,ggg
8,hhh
9,iii
10,jjj

今回は一つの文字列として最後に出力を行ったが、都度出力を行うやり方の方が分かりやすいかも。

[Excel][VBA] 処理の途中経過をステータスバーに表示する

VBAで処理を流すとき、件数が多ければ途中どれだけ処理したかが分からないまま固まってしまったような画面になってしまう。そこで処理の途中経過をステータスバーにメッセージとして表示することで、処理の進捗具合を確認できるようにする。

ステータスバーへのメッセージ表示は以下の文で行える。

Application.StatusBar = "処理実行中....(現在 " & i & "件)"

以下、サンプルのコード。

Sub macro1()

    Dim i As Integer
    
    '10000回表示を繰り返す
    For i = 1 To 10000
        '処理中の件数の表示
        Application.StatusBar = "処理実行中....(現在 " & i & "件)"
    Next i

    '完了と処理件数の表示
    Application.StatusBar = "処理完了....(全 " & i - 1 & "件)"
End Sub

処理中の表示。

完了時の表示。

[Excel][VBA]VBAで特殊文字を扱う

VBAで特殊文字を扱おうとしたところうまく行かなかった。
例えば©という文字、VBAのエディタ画面で入力すると「?」と表示されてしまう。

Dim str as String
str = "? 株式会社〇〇" ' 変換してもコピペしても入力できない。

調べた結果、ChrWというメソッドを使う必要があるらしい。

ChrW(/* 文字コード */)

引数に文字コードを渡して文字を表す。

ちなみにコピーライト「©」を表す文字コード(Unicode)は16進数でA9。
「© 〇〇株式会社」を表す文字列を入力するなら

Dim str as String
str = ChrW(&HA9) + " 株式会社〇〇" ' &Hは16進数を表す

とすればOK。

参考:Unicode一覧 0000-0FFF | Wikipedia

[Excel][VBA]複数のファイル、シートのヘッダー、フッターを一括で変更するマクロ

VBAからヘッダー、フッターを操作するには、シートオブジェクトのPageSetupオブジェクトを操作する。

Public Sub Main()
 ' 中央ヘッダーに「〇〇仕様書」という文字列を挿入
 WorkSheets("Sheets1").PageSetup.CenterHeader = "〇〇仕様書"
 ' 右下フッターに「株式会社〇〇」という文字列を挿入
 WorkSheets("Sheets1").PageSetup.RightFooter = "株式会社〇〇"
End Sub

指定したファイルの全シートに対して、フッターを差し替えなければ行けないということになったので、以下のようなマクロを作った。
前提条件として、対象ファイルのフルパスを取得し、A列に入力してあるものとする。

Sub changefoot()

    Dim book As Workbook
    Dim ws As Worksheet
    
    Dim file As String     ' ファイル名(フルパス)
    Dim filename As String ' ファイル名
    Dim tmp As Variant
    
    Dim Row As Long
	' リストの先頭から最後まで繰り返す
    For Row = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        ' ファイル名を取得
        file = Cells(Row, 1).Value
		
		' フルパスからファイル名を抽出
        tmp = Split(file, "¥")
        filename = tmp(UBound(tmp))
		
		' ファイルをオープンする
        Workbooks.Open (file)
		
		' オープンしたブックをアクティブにする
        Set book = Workbooks(filename)
		
		' 保存時の警告を非表示にする
        book.CheckCompatibility = False
		
		'すべてのシートに対して操作を行う。
        For Each ws In book.Worksheets
		   ' フッターの設定
            ws.PageSetup.LeftFooter = ""
            ws.PageSetup.CenterFooter = ""
            ws.PageSetup.RightFooter = "株式会社〇〇"
        Next
        
		'保存して閉じる
        Workbooks(filename).Close SaveChanges:=True
        
    Next
    
End Sub

実行結果は、A列に入力されたファイルのフッターがすべて、右下「株式会社〇〇」となる。

[Excel][VBA]上下で列を比較し、同じであれば色を付ける

仕事中に書いたExcelマクロをメモ。

上下でセルを比較し、同じであれば色を付ける。
このとき、連続する値が切り替わったとき、分かりやすいように赤と黄色で交互に色を付ける。
例えば以下のような表があったとすると

マクロ処理前

マクロ処理前

処理後は以下のようになる。

マクロ処理後

マクロ処理後


aaaは連続するので黄色、その後bbbも連続しているが、上のaaaと区別しやすいように色を変える。
cccは連続しないので色付けなし。
色は黄色、赤と切り替えていく。

ソースファイルは以下

Sub Macro1()
'上の行と比較して、列Aの値が同じであれば色を付けるマクロ
'連続する値が変わると、背景色を変える

    Dim coler As Integer      '色フラグ
    Dim flg As Integer        '連続フラグ
    Dim row As Long           '現在行
    
    Dim p_row_value As String '1行前のセルの値
    Dim n_row_value As String '現在行のセルの値
    
    '各変数の初期化
    p_row_value = ""
    n_row_value = ""
    coler = 0
    flg = 0
    
    '最終行まで繰り返す
    Dim i As Long
    For row = 1 To Cells(Rows.Count, 1).End(xlUp).row
    
        '現在行列Aの値を取得
        n_row_value = Cells(row, 1).Value
        
        '上の行と値が同じであれば色を付ける
        If n_row_value = p_row_value Then
               
            '連続が途切れた場合はカラーフラグを変更
            If flg = 0 Then
                '0なら1に、1なら0に
                coler = (coler + 1) Mod 2
            End If
                
        flg = 1  '連続フラグON
            
        Cells(row - 1, 1).Interior.Color = f_coler(coler) '上の行B列の色を変更
        Cells(row, 1).Interior.Color = f_coler(coler)     '現在行B列の色を変更
           
        Else
           flg = 0  '連続フラグOFF
        End If
        
        '現在行列Bの値をセット
        p_row_value = n_row_value
        
    Next row
    
    '完了表示
    MsgBox ("処理が完了しました。")

End Sub

Function f_coler(flg As Integer) As Long
    If flg = 0 Then
        'フラグが0であれば赤を返す
        f_coler = RGB(255, 0, 0)
    Else
        'フラグが1であれば黄を返す
        f_coler = RGB(255, 255, 0)
    End If
End Function

ちなみに、ループの条件は

For row = 1 To Cells(Rows.Count, 1).End(xlUp).row

列Aを最終行からさかのぼって、最初に値がある行まで。
これで途中が空白セルで抜けてても、最終行までチェックできる。

ついでにもう一個。
これはメモ。

Sub Macro2()

    Dim coler As Integer     '色
    Dim flg As Integer        '連続フラグ
    Dim row As Long           '現在行
    Dim s_row As Long         '開始行
    Dim e_row As Long         '終了行
    
    Dim p_row_value As String '1行前のセルの値
    Dim n_row_value As String '現在行のセルの値
    
    Dim i As Long             'ループ用カウンタ
    
    '各変数の初期化
    p_row_value = ""
    n_row_value = ""
    coler = 0
    flg = 0
    
    '最終行まで繰り返す
    For row = 1 To Cells(Rows.Count, 1).End(xlUp).row
        n_row_value = Cells(row, 1).Value
        
        '上の行と値が同じ時の処理
        If n_row_value = p_row_value Then
                
            '新たに連続が始まるときは連続の開始行を取得
            If flg = 0 Then
                coler = (coler + 1) Mod 2
                s_row = row - 1
            End If
            
            flg = 1  '連続フラグON
        
        
        '上の行と値が違う時の処理
        Else
            '連続が途切れたら連続の終了行を取得し表示処理
            If flg = 1 Then
                e_row = row - 1 '終了行の取得
                Call s_check(s_row, e_row) '表示処理
            End If
            
            '1行だけの場合は列bの値を見て、Yなら列cにYYを表示
            If Cells(row, 2).Value = "Y" Then
                Cells(row, 3).Value = "YY"
            End If
            
            flg = 0  '連続フラグOFF
            
        End If
        
        '現在行列Bの値をセット
        p_row_value = n_row_value
        
    Next row
    
    '完了表示
    MsgBox ("処理が完了しました。")

End Sub


Sub s_check(s As Long, e As Long)
'連続する行s〜eの列Eの値をチェックし、結果を列Hに表示する
'引数 s : 開始行
'引数 e : 終了行

    Dim i As Long
    Dim ii As Long
    Dim Yno As Long
    
    'Yが存在する行数の初期化
    Yno = 0
    
    行sから行eをチェック
    For i = s To e
        If Cells(i, 2).Value = "X" Then
        ElseIf Cells(i, 2).Value = "Y" Then
            'Yが存在すればその行数を保持
            Yno = i
        End If
    Next
    
    
    'Yが存在しなければ何もしない
    If Yno = 0 Then
    
    'Yが存在する行が最後
    ElseIf Yno = e Then
        For ii = s To e
            '行sから行eに削除を表示
            Cells(ii, 2) = "YY"
        Next ii
        
    'Yが存在する行が最後でない
    Else
        For ii = s To e
            '行sから行eにoutputを表示
            Cells(ii, 2) = "XX"
        Next ii
        
    End If
    
End Sub
  1. まず、列Aを上から見ていき、連続する値があるか調べる。
  2. 連続する値があれば、連続の開始行と終了行を取得する。
  3. 開始と終了の間の列Bをチェック
    • すべてXであれば何もしない。
    • Yが存在し、最終行がXであれば列Cの開始〜終了行までXXを表示
    • Yが存在し、最終行もYであれば列Cの開始〜終了行までYYを表示
  4. 単一行であれば、行Bをチェックし、Yのときのみ列CにYYを表示

実行前後のイメージはこんな感じ。

マクロ処理前

マクロ処理前


マクロ処理後

マクロ処理後

[Excel][VBA]2つのシートを比較して違うセルに色を付ける

仕事でサイズの大きな複数ののCSVファイルを比較することがよくある。
エクセルに開いてマクロで結果を出すのが効率的なので、2つのシートを比較するマクロをメモしておく。

Sub Macro()
'
' 2つのシートの同じ位置のセルの値を比較し、
' 等しくなければそのセルを赤で塗りつぶす。

'
  Dim RETSU_S, RETSU_E, GYOU_S, GYOU_E As Long
  RETSU_S = 1 '列をAから
  RETSU_E = 10 '列をJまで
  GYOU_S = 2 '行を2から
  GYOU_E = 101 '行を101まで

  Dim s1, s2 As Worksheet 'Worksheetsオブジェクト用
  Set s1 = Worksheets("Sheet1") '比較元シート名
  Set s2 = Worksheets("Sheet2") '比較先シート名

  Dim retsu, gyou As Long 'この変数で列と行を指定する

  For gyou = GYOU_S To GYOU_E '開始行から終了行まで
    For retsu = RETSU_S To RETSU_E '開始列から終了列まで
      If s1.Cells(gyou, retsu).Value <> s2.Cells(gyou, retsu).Value Then 
	  '同じ位置のセルの値が等しくなければ、そのセルを赤で塗りつぶす。
        s1.Cells(gyou, retsu).Interior.Color = RGB(255, 0, 0)
		s2.Cells(gyou, retsu).Interior.Color = RGB(255, 0, 0)
      End If
    Next
  Next

End Sub

比較する内容や、セルの色を変えることで応用できると思う。