オートフィルを使ったマクロを作りましたが、時間がかかります。

初心者です。
検索で拾ったコードを組み合わせて、下のようなコードでマクロを作りました。
2万行を超えるデータを、オートフィルである列の中から「1」以外を行で削除するようにします。
実際に実行すると、時間がかかりポインタがクルクルとなっています。
もっと早く処理できるようにできますでしょうか。どこかおかしいところがありますでしょうか。
ご指摘のほどよろしくお願いします。

Sub コマンドボタン枝番_Click()

Dim intRowCount, i As Integer
Dim lngTotal, lngWriteTotal As Long

If MsgBox("枝番1以外を削除します。" & vbCrLf & _
"処理を実行しますか?", vbYesNo + vbQuestion, "行削除マクロ") = vbNo Then
Exit Sub

End If

Application.ScreenUpdating = False

lngTotal = Application.WorksheetFunction.CountA(Range("AV2:AV40000"))

Worksheets("全体").Activate
Worksheets("全体").Range("AV1").Select
Selection.AutoFilter

Selection.CurrentRegion.Select
intRowCount = Selection.Rows.Count + 1

ActiveSheet.Range("$A$1:$BO$40000").AutoFilter Field:=48, Criteria1:=">1", _
Operator:=xlAnd
Rows("2:40000").Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter
Application.Goto reference:=Range("A1"), Scroll:=True

lngWriteTotal = WorksheetFunction.CountA(Range("AV2:AV40000"))

MsgBox "処理を完了しました。" & vbCrLf & _
"件数:" & vbCrLf & lngWriteTotal

Worksheets("手順シート").Activate

Application.ScreenUpdating = True

Exit Sub

End Sub

質問者からの補足コメント

• ご回答ありがとうございます。
  早速、コードを実行しましたところ、myStr = myStr & myR(i, j) & "_"　でエラーになります。
  何か、変更や追加しないといけなかったでしょうか。
  ご面倒をおかけいたしますが、ご教授いただけますでしょうか。

  No.4の回答に寄せられた補足コメントです。 補足日時：2019/04/13 15:17

• ご面倒をおかけして申し訳ありません。
  列は、A列からBO列まであり、登録日、お客様名、住所、発注番号、･･･、枝番、･･･です。
  AV列が枝番です。
  
  すみませんが、根本的な話で恐縮ですが、
  教えていただきましたコードは、元データのどこからどこまでと交換するのでしょか。

  No.5の回答に寄せられた補足コメントです。 補足日時：2019/04/13 23:46

No.1 ベストアンサー 回答者： zongai 回答日時： 2019/04/12 01:51

オートフィルタの状態で削除するから、実際は飛び飛びの行削除になっててそこで処理が重くなってるんじゃないかと。

先に、AV列（48番目の列）でソートをかけてしまって、
そののちに1以外（１より大きい数でいいんですよね？）をフィルターすると、
連続した列の削除になるので、処理時間が短くなります。

投稿されたコードの途中に★★★で囲まれた部分を追加して、処理速度を確認してみてください。

・・・
lngTotal = Application.WorksheetFunction.CountA(Range("AV2:AV40000"))
Worksheets("全体").Activate
'★★★
ActiveWorkbook.Worksheets("全体").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("全体").Sort.SortFields.Add Key:=Range("AV2:AV40000") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("全体").Sort
.SetRange Range("A1:BO40000")
.Header = xlYes
.Apply
End With
'★★★★
Worksheets("全体").Range("AV1").Select
Selection.AutoFilter
・・・

この回答へのお礼

処理速度が全然違いますね。あっという間に完了しました。
本当に助かりました。
勉強になりました。
ありがとうございます。

お礼日時：2019/04/12 13:22

No.7 回答者： tom04 回答日時： 2019/04/14 10:53

たびたびごめんなさい。

No.6の最後で記載した部分（どこかのセルに「_」をつかっていないか？)
が気になったのでためしに、該当行にアンダーバー入りの文字列のセルで試してみました。

＞myStr = myStr & myR(i, j) & "_"

の行でエラーになってしまいました。
というコトはおそらくセル内にアンダーバー入りのセルがあるのでは？

No.4のコードの
＞myStr = myStr & myR(i, j) & "_"
と
＞myAry = Split(myKey(i), "_")
の2行のアンダーバーの部分を
カンマなど使っていない文字に変更してみてください。

＞myStr = myStr & myR(i, j) & ","
といった感じで・・・

※　カンマに限らず「#」などどんな文字でも構いません。
セル内に存在しない文字にします。m(_ _)m

この回答へのお礼

ありがとうございました。

お礼日時：2019/04/14 23:00

No.6 回答者： tom04 回答日時： 2019/04/14 10:22

No.4・5です。

＞元データのどこからどこまでと交換するのでしょか。

前回のコードは「全体」シートの
＞lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
でA列最終行を取得

＞lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
で1行目項目行の最終列を取得するようにしていますので、

A列と1行目に最終行・最終列までデータがちゃんと入っていれば
その範囲すべてが対象になっているはずです。

2行目以降を検索し、AV列が「1」の場合の行のみ
A列から各行のデータを項目名がある最終列までアンダーバー「_」で連結し
各行すべての「連結文字」を一旦仮想配列に登録しています。

項目名がBD列まで入っているのであれば
仮に、AV2セルが「1」の場合
A2_B2_C2_・・・・_BD2

という具合に該当行（残す行？）のみ登録しています。

最後にA列～最終列2行目以降のデータを一旦消去し
A2セル以降に登録している行データを
「_」で分割させ、各列に表示させる！

といった流れのコードです。

※　注意点として、
万一、アンダーバー「_」を使っているセルがある場合は誤作動しますので、
区切り文字をカンマ「,」などの使っていない文字にする必要があるかもしれません。m(_ _)m

No.5 回答者： tom04 回答日時： 2019/04/13 19:43

No.4です。

＞myStr = myStr & myR(i, j) & "_"　でエラーになります。

他のところでエラーになる可能性はあっても、
この行は単純に
A列～最終列のセルを「_」で繋いでいるだけなので、この行でエラーになるコト自体が考えにくいのですが・・・

セルはどのようなデータが入っているのでしょうか？
その辺が判れば少しはお役に立てるかもしれません。

※　前回のコードで最初の5行で色々変数の宣言をしていますが、
もちろんそれはそのままありますよね？m(_ _)m

No.4 回答者： tom04 回答日時： 2019/04/12 11:24

こんにちは！

オートフィルタではなく別案です。
値だけの操作で、AV列が1のデータのみを「全体」シートに残すようにしてみました。

本来であれば元データを削除するより、別シートに書き出す方が良いと思うのですが、
元データに手を付けています。

尚、1行目は項目行でデータは2行目以降にあり、
A列で最終行を取得していますので、A列にはAV列の最終行と同じ行までデータがある！という前提です。
標準モジュールです。

Sub Sample1()
　Dim myDic As Object
　Dim i As Long, j As Long
　Dim lastRow As Long, lastCol As Long
　Dim myStr As String, buf As String
　Dim myKey, myR, myAry

　　Set myDic = CreateObject("Scripting.Dictionary")
　　With Worksheets("全体")
　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, lastCol))
　　　　　For i = 1 To UBound(myR, 1)
　　　　　　If myR(i, 48) = 1 Then
　　　　　　　For j = 1 To lastCol
　　　　　　　　myStr = myStr & myR(i, j) & "_"
　　　　　　　Next j
　　　　　　　　buf = Left(myStr, Len(myStr) - 1)
　　　　　　　If Not myDic.exists(buf) Then
　　　　　　　　myDic.Add buf, ""
　　　　　　　End If
　　　　　　End If
　　　　　　myStr = ""
　　　　　Next i
　　　　myKey = myDic.keys
　　　　　Range(.Cells(2, "A"), .Cells(lastRow, lastCol)).ClearContents
　　　　myR = Range(.Cells(2, "A"), .Cells(UBound(myKey) + 2, lastCol))
　　　　　For i = 0 To UBound(myKey)
　　　　　　myAry = Split(myKey(i), "_")
　　　　　　　For j = 0 To UBound(myAry)
　　　　　　　　myR(i + 1, j + 1) = myAry(j)
　　　　　　　Next j
　　　　　Next i
　　　　Range(.Cells(2, "A"), .Cells(UBound(myKey) + 2, lastCol)) = myR
　　　　　Set myDic = Nothing
　　End With
　　　MsgBox "完了" & vbCrLf & "件数：" & UBound(myKey) + 1 & "件"
End Sub

こんな感じではどうでしょうか。

ちなみにこちらで試した結果
6万行のサンプルで約5秒かかりました。m(_ _)m

No.3 回答者： usa00 回答日時： 2019/04/12 06:14

追記

元のシートをB列が１のみで書き換えるのであれば、

' 表示データクリア

Sheets("Sheet1").Range("A:B").Value = ""

curRow = 1
Do Until rs.EOF
Sheets("Sheet1").Range("A" & curRow).Value = rs!F1
Sheets("Sheet1").Range("B" & curRow).Value = rs!F2
rs.MoveNext
curRow = curRow + 1
Loop

とします。

元の表の1行目に、列の見出しを付ける場合、
A列の見出し＝項目
B列の見出し＝枝番

'1行目がヘッダの場合はHDR=YESにする。NOの場合はF1,F2,F3・・・と番号が振られる。

cn.Properties("Extended Properties") = "Excel 12.0;HDR=YES;IMEX=1"


SQLは、

'---------------------------------------
'項目(A列),枝番(B列)を抽出
'WHERE(条件）　枝番(B列)が1のデータを抽出
' 項目(A列)で並べ替え
'---------------------------------------
sql = "SELECT" _
& " 項目, 枝番" _
& " FROM [Sheet1$]" _
& " WHERE 枝番=1" _
& " ORDER BY 項目"
rs.Open sql, cn, adOpenStatic

' 表示データクリア

Sheets("Sheet1").Range("A:B").Value = ""
Sheets("Sheet1").Cells(1, 1) = "項目"
Sheets("Sheet1").Cells(1, 2) = "枝番"

curRow = 2
Do Until rs.EOF
Sheets("Sheet1").Range("A" & curRow).Value = rs!F1
Sheets("Sheet1").Range("B" & curRow).Value = rs!F2
rs.MoveNext
curRow = curRow + 1
Loop

この回答へのお礼

ありがとうございました。

お礼日時：2019/04/15 00:27

No.2 回答者： usa00 回答日時： 2019/04/12 05:54

SQLを使ってみてはいかがでしょうか？

オートフィルタを適用するために、範囲選択したり、フィルタをつけたり外したり、
無駄な動作が多くなりますね。

EXCEL　SQLで検索すると、出てきますよ。

SQLを使うと、データの抽出が簡単にできます。

例えば、
A列、B列のデータを抽出。ただし、B列のデータが”１”のデータのみ抽出してSheet２
に貼り付ける。

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim xl_file As String
Dim sql As String
Dim curRow As Integer

'ツールメニューの参照設定'
' Microsoft ActiveX Data Objects 2.8 Library'
'チェック'
xl_file = ThisWorkbook.FullName '他のブックを指定しても良い'

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
'1行目がヘッダの場合はHDR=YESにする。NOの場合はF1,F2,F3・・・と番号が振られる。

cn.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"

cn.Open ThisWorkbook.FullName '自ワークブックのファイル名を指定しているが、

Set rs = New ADODB.Recordset

'---------------------------------------
'F1(A列),F2(B列)を抽出
'WHERE(条件）　F2(B列)が1のデータを抽出
' F1(A列)で並べ替え
'---------------------------------------
sql = "SELECT" _
& " F1, F2" _
& " FROM [Sheet1$]" _
& " WHERE F2=1" _
& " ORDER BY F1"
rs.Open sql, cn, adOpenStatic

' 表示データクリア

Sheets("Sheet2").Range("A:D").Value = ""

curRow = 1
Do Until rs.EOF
Sheets("Sheet2").Range("A" & curRow).Value = rs!F1
Sheets("Sheet2").Range("B" & curRow).Value = rs!F2
rs.MoveNext
curRow = curRow + 1
Loop

MsgBox "処理を完了しました。" & vbCrLf & _
"件数:" & vbCrLf & curRow - 1

rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing