Sub CopyRowsToNewSheet()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim data As Variant
Dim filteredData() As Variant
Dim i As Long, targetIndex As Long
' タイマーを開始
StopWatch.StartTimer
' 元データのシートを設定
Set wsSource = ThisWorkbook.Worksheets("売上一覧")
' 最終行を取得
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
' データを配列に読み込む
data = wsSource.Range("A1:C" & lastRow).Value
' フィルタリング用の配列を初期化
targetIndex = 0
' 条件に一致する行をチェックし、カウント
For i = 1 To UBound(data, 1)
If data(i, 3) >= 5000 Then ' C列の金額が5000円以上
targetIndex = targetIndex + 1
End If
Next i
' フィルタリング用の配列を実際の行数に基づいて初期化
If targetIndex > 0 Then
ReDim filteredData(1 To targetIndex, 1 To 3)
' 再度ループしてフィルタリング
targetIndex = 0
For i = 1 To UBound(data, 1)
If data(i, 3) >= 2000 Then ' C列の金額が5000円以上
targetIndex = targetIndex + 1
filteredData(targetIndex, 1) = data(i, 1) ' A列
filteredData(targetIndex, 2) = data(i, 2) ' B列
filteredData(targetIndex, 3) = data(i, 3) ' C列
End If
Next i
Else
MsgBox "条件に一致する行はありませんでした。"
Exit Sub
End If
' 新しいシートを作成
Set wsTarget = ThisWorkbook.Worksheets.Add
wsTarget.Name = "条件に一致する行"
' フィルタリングされたデータを新しいシートに貼り付け
wsTarget.Range("A1:C" & targetIndex).Value = filteredData
' 列幅を自動調整
wsTarget.Columns("A:C").AutoFit
' タイマーを停止
StopWatch.StopTimer
' 経過時間を表示
MsgBox StopWatch.GetFormattedElapsedTime()
End Sub
Sub CopyRowsToSameSheet()
Dim ws As Worksheet
Dim lastRow As Long
Dim data As Variant
Dim filteredData() As Variant
Dim i As Long, targetIndex As Long
' タイマーを開始
StopWatch.StartTimer
' 元データのシートを設定
Set ws = ThisWorkbook.Worksheets("売上一覧")
' 最終行を取得
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' データを配列に読み込む
data = ws.Range("A1:C" & lastRow).Value
' フィルタリング用の配列を初期化
targetIndex = 0
' 条件に一致する行をチェックし、カウント
For i = 1 To UBound(data, 1)
If data(i, 3) >= 2000 Then ' C列の金額が2,000円以上
targetIndex = targetIndex + 1
End If
Next i
' フィルタリング用の配列を実際の行数に基づいて初期化
If targetIndex > 0 Then
ReDim filteredData(1 To targetIndex, 1 To 3)
' 再度ループしてフィルタリング
targetIndex = 0
For i = 1 To UBound(data, 1)
If data(i, 3) >= 2000 Then ' C列の金額が2,000円以上
targetIndex = targetIndex + 1
filteredData(targetIndex, 1) = data(i, 1) ' A列
filteredData(targetIndex, 2) = data(i, 2) ' B列
filteredData(targetIndex, 3) = data(i, 3) ' C列
End If
Next i
Else
MsgBox "条件に一致する行はありませんでした。"
Exit Sub
End If
' 元のシートにフィルタリングされたデータを貼り付ける
ws.Range("A1:C" & targetIndex).Value = filteredData
' 残りの行を削除
If targetIndex < lastRow Then
ws.Rows(targetIndex + 1 & ":" & lastRow).Delete
End If
' 列幅を自動調整
ws.Columns("A:C").AutoFit
' タイマーを停止
StopWatch.StopTimer
' 経過時間を表示
MsgBox StopWatch.GetFormattedElapsedTime()
End Sub
配列を使った行削除の結果は、10.95秒でした！
フィルタを使った行削除
それでは、フィルタ機能使って条件に一致する行をまとめて削除してみましょう！
コード
Option Explicit
Sub CopyFilteredRowsToNewSheet()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
' タイマーを開始
StopWatch.StartTimer
' 元データのシートを設定
Set wsSource = ThisWorkbook.Worksheets("売上一覧") ' 元データシート名を指定
' 最終行を取得
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
' フィルタを適用
With wsSource
.AutoFilterMode = False ' 既存のフィルタを解除
.Range("A1:C" & lastRow).AutoFilter field:=3, Criteria1:=">=2000" ' C列をフィルタリング
End With
' 新しいシートを作成
Set wsTarget = ThisWorkbook.Worksheets.Add
wsTarget.Name = "条件に一致する行"
' フィルタリングされたデータをコピー
wsSource.Range("A1:C" & lastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=wsTarget.Range("A1")
' フィルタを解除
wsSource.AutoFilterMode = False
' 列幅を自動調整
wsTarget.Columns("A:C").AutoFit
' タイマーを停止
StopWatch.StopTimer
' 経過時間を表示
MsgBox StopWatch.GetFormattedElapsedTime()
End Sub
実行してみましょう！
AutoFilter field:=3, Criteria1:=">=2000"
で、フィルタが実行されます。
If Not targetRange Is Nothing Then
targetRange.Delete shift:=xlUp
End If
Option Explicit
Sub DeleteRowsAbove5000()
Dim i As Long
Dim lastRow As Long
' タイマーを開始
StopWatch.StartTimer
' 最終行を取得
lastRow = Cells(Rows.Count, 3).End(xlUp).Row ' C列の最終行を取得
' 最終行から1行目に向かってループ
For i = lastRow To 1 Step -1
' C列の値が2,000円以上の場合
If Cells(i, 3).Value >= 2000 Then
Rows(i).Delete ' 行を削除
End If
Next i
' タイマーを停止
StopWatch.StopTimer
' 経過時間を表示
MsgBox StopWatch.GetFormattedElapsedTime()
End Sub
コメント