Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

20278 / 76732

←次へ　｜　前へ→


	【61876】Re:消去作業について

Hirofumi - 09/6/10(水) 9:47 -


	引用なし

	パスワード

コードにするとこんなかな？
幾分速く成ると思います

Option Explicit

Public Sub Sample()

　　Dim i As Long
　　Dim lngRows As Long　　　 'データ行数
　　Dim lngCount As Long　　　'削除数
　　Dim vntSheets As Variant　'対象シート名の一覧
　　Dim vntTop As Variant　　 '対象シートのデータ先頭行
　　Dim vntColumns As Variant '対象シートの最終データ列位置
　　Dim lngDelete() As Long　　 '削除行のFlag
　　Dim vntKeys1 As Variant
　　Dim vntKeys2 As Variant
　　
　　vntSheets = Array("D1", "D2", "D3", "D4", "D5", "D6")
　　vntTop = Array(3, 3, 3, 3, 3, 1)
　　vntColumns = Array(130, 130, 130, 130, 130, 130)
　　
　　lngRows = 800
　　
　　'D1シートに就いて
　　With Worksheets(vntSheets(0))
　　　　'130列のデータを配列に取得
　　　　vntKeys1 = .Range(.Cells(vntTop(0), 130), _
　　　　　　　　　　　　.Cells(vntTop(0) + lngRows - 1, 130)).Value
　　　　'1列のデータを配列に取得
　　　　vntKeys2 = .Range(.Cells(vntTop(0), 1), _
　　　　　　　　　　　　.Cells(vntTop(0) + lngRows - 1, 1)).Value
　　End With
　　'削除Flag用の配列を確保
　　ReDim lngDelete(1 To lngRows, 1 To 1)
　　
　　'削除Flagを作成
　　For i = 1 To lngRows
　　　　If vntKeys1(i, 1) = "" Or vntKeys2(i, 1) < 50 Then
　　　　　　lngDelete(i, 1) = 1
　　　　　　lngCount = lngCount + 1
　　　　End If
　　Next i
　　
　　'削除する行が在るなら
　　If lngCount > 0 Then
　　　　'シート一覧に基いて
　　　　For i = 0 To UBound(vntSheets)
　　　　　　With Worksheets(vntSheets(i))
　　　　　　　　'最終列の後ろに削除Flagを出力
　　　　　　　　.Cells(vntTop(i), vntColumns(i) + 1).Resize(lngRows).Value = lngDelete
　　　　　　　　'削除FlagをKeyとしてListを整列
　　　　　　　　.Cells(vntTop(i), 1).Resize(lngRows, vntColumns(i) + 1).Sort _
　　　　　　　　　　　　key1:=.Cells(vntTop(i), vntColumns(i) + 1), Order1:=xlAscending, _
　　　　　　　　　　　　Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
　　　　　　　　　　　　Orientation:=xlTopToBottom, SortMethod:=xlStroke
　　　　　　　　'削除Flagが1の行を削除
　　　　　　　　.Cells(vntTop(i) + lngRows - lngCount, 1).Resize(lngCount).EntireRow.Delete
　　　　　　　　'削除Flagを削除
　　　　　　　　.Cells(vntTop(i), vntColumns(i) + 1).EntireColumn.Delete
　　　　　　End With
　　　　Next i
　　End If
　　
End Sub

0 hits

▼

【61871】消去作業について YOUSUKE 09/6/10(水) 1:05