Excel 横方向の数値が全て0の行を削除する(3)VBA・2次元配列で簡易的に実施する

はじめに

Excel 横方向の数値が全て0の行を削除する方法(2)VBAを作ってみた

2020年3月24日

以前の記事で、横方向の数値が全て0の行を削除するマクロを書いた。

しかしこれ、別に間違ったソースコードでもないつもりだが、実際に会社のPCで使ってみたら、10万行程度のデータになるとキツくなった。

このマクロでは、横方向が全て0の行を見つけるたびに、律儀に1回ずつ削除するので、削除の回数が多くなると処理負荷が大きくなる。

それでも10万行程度ならイケると思っていたのだが、処理途中で固まってまともに使えないマクロとなってしまった。

処理を軽くするには、VBAの2次元配列を使えば良いと分かってはいるのだが、元々のシートの書式や数式を崩したくないとこだわって、処理が重くもっさりしたマクロになってしまった。

そこで今回は、

表の見出し行が必ずA1セルから始まり1行目にある。
計算式は入っていなくて値のみ。書式なども気にしなくて良い。

といった単純な表を対象にすると割り切って、2次元配列を使ってより軽快に動くマクロにしてみた。

動作イメージ

では簡単に、マクロの動作イメージを。
マクロを起動すると、セル範囲を選ばせるInputBoxが出る。

これに対し、横方向が全て0のデータを除外したい列を選ぶ。
列全体を選択しても良いし、単一セルの選択でも良い。

上図の例では$F$2:$H$3のセル範囲を選んでいるが、この場合なら、F列～H列の数値が全て0の行を削除する処理をかけることになる。
結果、削除されず残るのは№02(B社)・№03(C社)の2行になる。

ソースコード

ではマクロのソースコードを。
やたら長ったらしいけど、特に要領良く書いてるわけでもなく、中身は力技です。

Option Explicit

Dim fullArr     As Variant
Dim ws          As Worksheet
Dim fullRng     As Range
Dim fullRSize   As Long
Dim fullCSize   As Long
Dim startC      As Long
Dim endC        As Long

'横方向が全て0の行を簡易的に削除する。
'***************************前提条件***************************
'(1)表の見出し行は、ExcelシートのA1セルから始まる1行目にある。
'(2)計算式は入っていない。入っていても値のみに直して良い。
'(3)行・列の非表示やフィルタリングは掛かっていない。
'(4)書式設定などは入っていない。
'*******************前提条件ここまで***************************

'*******************処理内容***********************************
'(1)まず、横方向が全て0のデータを除外したい列を選ばせる。
'列が含まれてさえいれば、列全体を選択しても良いし、
'単一セルの選択でも良い。
'(2)横方向が全て0のデータを除外した2次元配列を作成。
'(3)表のデータをいったん全削除して、2次元配列を代入する。
'*******************処理内容ここまで***************************

Sub remakeWithoutAllZeroRows()
    '事前チェック
    If Not fncBeforeRemakeWithoutAllZeroRows Then Exit Sub
    
    Call appSet '描画省略等
    
    Dim rewriteArr  As Variant
    Dim r           As Long
    Dim c           As Long
    Dim cnt         As Long
    Dim flg         As Boolean
    
    ReDim rewriteArr(1 To fullRSize, 1 To fullCSize)
    
    For r = 1 To fullRSize
        For c = startC To endC '数値項目のみ見ていく
            If fullArr(r, c) * 1 = 0 Then
            Else
                '0以外が1個でもあった時点で実行フラグSET
                flg = True
                '転記用行数を+1
                cnt = cnt + 1
                Exit For
            End If
        Next c
    
        '0以外が1個でもあるなら、転記用配列に転記
        If flg Then
            For c = 1 To fullCSize
                rewriteArr(cnt, c) = fullArr(r, c)
            Next c
            
            flg = False 'リセット
        End If
        
    Next r
    
    '削除対象行が無かった場合
    If cnt = fullRSize Then
        Call appReset '描画等再開
        MsgBox "削除対象の行はありませんでした。", vbInformation, "削除対象なし"
        Exit Sub
    End If
    
    '削除対象行があった場合
    '2行目以降をいったん削除
    fullRng.EntireRow.Delete
    
    '転記用2次元配列を代入
    ws.Cells(2, 1).Resize(cnt, fullCSize).Value = rewriteArr
    Call appReset '描画等再開
    MsgBox "終了しました。", vbInformation, "処理終了"

End Sub


Function fncBeforeRemakeWithoutAllZeroRows() As Boolean
    Set ws = ActiveSheet
    
    Dim lastRng     As Range
    Dim msg         As String
    
    Set lastRng = ws.Cells.SpecialCells(xlCellTypeLastCell)
    fullRSize = lastRng.Row - 1 'タイトル行を除く、表全体の行数
    
    If fullRSize = 0 Then
        msg = "データが2行以上ある場合のみ処理実行します。"
        MsgBox msg, vbExclamation, "データ数不足"
        Exit Function
    End If
    
    'タイトル行を除く、表全体のデータ
    Set fullRng = Range(ws.Cells(2, 1), lastRng)
    fullArr = fullRng.Value '表全体の数式データを2次元配列へ
    fullCSize = fullRng(fullRng.Count).Column '表全体の列数
    
    msg = "横方向が全て0のデータを除外したい列を、選択して下さい。"
    
    'Application.InputBoxの主なType
    '0:数式
    '1:数値
    '2:文字列
    '8:セル参照
    'セル範囲を返す(Type:=8)のInputBoxでは、受け取り値をRange型に限定しておき、
    'キャンセルが押されたときはエラー処理で良い。
    Dim rng         As Range
    
    On Error GoTo theEnd
    
    Set rng = Application.InputBox(msg, Title:=msg, Type:=8)
    
    startC = rng(1).Column '数値列の開始列
    
    If startC > fullCSize Then
        msg = "表の範囲内で列を指定して下さい。"
        MsgBox msg, vbExclamation, "列指定不適切"
        Exit Function
    End If
    
    endC = rng(rng.Count).Column '数値列の終了列
    '終了列が、表の最大列数をオーバーしないようにする
    endC = WorksheetFunction.Min(endC, fullCSize)
    
    fncBeforeRemakeWithoutAllZeroRows = True '実行フラグSET
theEnd:
    Exit Function
End Function


Sub appSet()
'マクロ処理中に、描画など余計なものを省略して高速化
    With Application
        .ScreenUpdating = False '描画を省略
        .Calculation = xlCalculationManual '手動計算
        .DisplayAlerts = False '警告を省略。
'        .EnableEvents = False 'DisplayAlertsよりこちらを設定した方が良いのかな？
    End With
End Sub

Sub appReset()
'描画などの設定をリセット
    With Application
        .ScreenUpdating = True '描画する
        .Calculation = xlCalculationAutomatic '自動計算
        .DisplayAlerts = True '警告を行う
    End With
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

Option Explicit

Dim fullArr As Variant

Dim ws As Worksheet

Dim fullRng As Range

Dim fullRSize As Long

Dim fullCSize As Long

Dim startC As Long

Dim endC As Long

'横方向が全て0の行を簡易的に削除する。

'***************************前提条件***************************

'(1)表の見出し行は、ExcelシートのA1セルから始まる1行目にある。

'(2)計算式は入っていない。入っていても値のみに直して良い。

'(3)行・列の非表示やフィルタリングは掛かっていない。

'(4)書式設定などは入っていない。

'*******************前提条件ここまで***************************

'*******************処理内容***********************************

'(1)まず、横方向が全て0のデータを除外したい列を選ばせる。

'列が含まれてさえいれば、列全体を選択しても良いし、

'単一セルの選択でも良い。

'(2)横方向が全て0のデータを除外した2次元配列を作成。

'(3)表のデータをいったん全削除して、2次元配列を代入する。

'*******************処理内容ここまで***************************

Sub remakeWithoutAllZeroRows()

'事前チェック

If Not fncBeforeRemakeWithoutAllZeroRows Then Exit Sub

Call appSet '描画省略等

Dim rewriteArr As Variant

Dim r As Long

Dim c As Long

Dim cnt As Long

Dim flg As Boolean

ReDim rewriteArr(1 To fullRSize, 1 To fullCSize)

For r = 1 To fullRSize

For c = startC To endC '数値項目のみ見ていく

If fullArr(r, c) * 1 = 0 Then

Else

'0以外が1個でもあった時点で実行フラグSET

flg = True

'転記用行数を+1

cnt = cnt + 1

Exit For

End If

Next c

'0以外が1個でもあるなら、転記用配列に転記

If flg Then

For c = 1 To fullCSize

rewriteArr(cnt, c) = fullArr(r, c)

Next c

flg = False 'リセット

End If

Next r

'削除対象行が無かった場合

If cnt = fullRSize Then

Call appReset '描画等再開

MsgBox "削除対象の行はありませんでした。", vbInformation, "削除対象なし"

Exit Sub

End If

'削除対象行があった場合

'2行目以降をいったん削除

fullRng.EntireRow.Delete

'転記用2次元配列を代入

ws.Cells(2, 1).Resize(cnt, fullCSize).Value = rewriteArr

Call appReset '描画等再開

MsgBox "終了しました。", vbInformation, "処理終了"

End Sub

Function fncBeforeRemakeWithoutAllZeroRows() As Boolean

Set ws = ActiveSheet

Dim lastRng As Range

Dim msg As String

Set lastRng = ws.Cells.SpecialCells(xlCellTypeLastCell)

fullRSize = lastRng.Row - 1 'タイトル行を除く、表全体の行数

If fullRSize = 0 Then

msg = "データが2行以上ある場合のみ処理実行します。"

MsgBox msg, vbExclamation, "データ数不足"

Exit Function

End If

'タイトル行を除く、表全体のデータ

Set fullRng = Range(ws.Cells(2, 1), lastRng)

fullArr = fullRng.Value '表全体の数式データを2次元配列へ

fullCSize = fullRng(fullRng.Count).Column '表全体の列数

msg = "横方向が全て0のデータを除外したい列を、選択して下さい。"

'Application.InputBoxの主なType

'0:数式

'1:数値

'2:文字列

'8:セル参照

'セル範囲を返す(Type:=8)のInputBoxでは、受け取り値をRange型に限定しておき、

'キャンセルが押されたときはエラー処理で良い。

Dim rng As Range

On Error GoTo theEnd

Set rng = Application.InputBox(msg, Title:=msg, Type:=8)

startC = rng(1).Column '数値列の開始列

If startC > fullCSize Then

msg = "表の範囲内で列を指定して下さい。"

MsgBox msg, vbExclamation, "列指定不適切"

Exit Function

End If

endC = rng(rng.Count).Column '数値列の終了列

'終了列が、表の最大列数をオーバーしないようにする

endC = WorksheetFunction.Min(endC, fullCSize)

fncBeforeRemakeWithoutAllZeroRows = True '実行フラグSET

theEnd:

Exit Function

End Function

Sub appSet()

'マクロ処理中に、描画など余計なものを省略して高速化

With Application

.ScreenUpdating = False '描画を省略

.Calculation = xlCalculationManual '手動計算

.DisplayAlerts = False '警告を省略。

' .EnableEvents = False 'DisplayAlertsよりこちらを設定した方が良いのかな？

End With

End Sub

Sub appReset()

'描画などの設定をリセット

With Application

.ScreenUpdating = True '描画する

.Calculation = xlCalculationAutomatic '自動計算

.DisplayAlerts = True '警告を行う

End With

End Sub

検索

最新の投稿

月別アーカイブ

Excel 横方向の数値が全て0の行を削除する(3)VBA・2次元配列で簡易的に実施する

はじめに

動作イメージ

ソースコード

関連記事等

プロフィール

自己紹介など

最近の投稿

Excel 見出しタイトルが一致する列のデータを、関数で取得する

Excelのバージョンについて

Excel(Microsoft365)2022/08新規追加された関数(2)文字列操作系の関数

Excel(Microsoft365)2022/08新規追加された関数(1)配列操作系の関数

Excel 財務関数(6)XNPV関数(期間も金額も不規則な現在価値)

Excel 財務関数(5)NPV関数(期間が一定、金額が不規則な現在価値)

Excel 財務関数(4)現在価値に関し利息・元金の特定期間における支払額を求める関数

Excel 財務関数(3)現在価値PV関数と資本回収係数PMT

Excel 財務関数について(2)将来価値FV関数と減債基金係数PMT

Excel 財務関数について(1)導入

PowerQuery 1行上のデータと比較する

PowerQuery 数値が全て0の行は削除、そして空白セルには0を埋める

Excel VBA 簡易的なファイル名変更・移動のツール

Excel PowerQueryで住所の加工ほか、住所録を作成

Excel FILTER関数(2)オートフィルタ以上の便利な使い方

Excel FILTER関数(1)基本事項

アーカイブ

カテゴリー

オススメ商品