にっきダイアリー

はてなダイアリーからはてなblogに移動してみました。

Excel VBA 小ネタマクロ

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

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

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

これが、

f:id:Nikki_A:20160830153531j:plain

こうなる

f:id:Nikki_A:20160830153544j:plain

以下ソース。あ、内部で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

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

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

これが

f:id:Nikki_A:20160830154839j:plain

こうなる

f:id:Nikki_A:20160830154845j:plain

サンプルみたいな単純な表だと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

'-----------------------------------------------------------------------
' 指定の列にデータが含まれない行を削除するマクロ
' チェックする列は3つまで
'-----------------------------------------------------------------------
' 指定の列にデータが含まれない行を削除するマクロ
' チェックする列は3つまで
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

いわずもがなですが

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