| |
こんなでは？
Listの先頭見出し位置をrngListで指定
空白を検出する列をclngKeyで指定
（基準位置「rngList」がA列なら、基準位置A列から検出列A列の列Offsetで0
例えば、基準位置A列で検出列B列なら列Offsetで1
基準位置B列で検出列B列なら列Offsetで0
基準位置B列で検出列C列なら列Offsetで1）
Listの列数をclngColumnsで指定
例えば、ListがA列〜G列なら7列で、8列目（H列）に作業列が設けられ
削除される行は1が立てられ、されない行は0に成ります
作業列（H列）をKeyとしてListが整列されます
Excelは安定な整列を行う為、Listの順位は変わりません
多分、teianさんのコードもListの順位は変わらない筈です
Option Explicit
Public Sub Sample()
'★データの列数(A列〜G列)
Const clngColumns As Long = 7
'★空白の検出列位置を設定 (基準列位置からの列Offsetで指定､A列)
'基準位置（rngList）がA列なら、A列からA列の列Offsetで0
Const clngKey As Long = 0
Dim i As Long
Dim lngRows As Long
Dim lngCount As Long
Dim rngList As Range
Dim vntData As Variant
Dim lngDelete() As Long
Dim strProm As String
'★データの左上隅を基準位置とする（列見出し「商品コード」の位置）
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'検出列データを配列に取得
vntData = .Offset(1, clngKey).Resize(lngRows + 1).Value
End With
'Flagを格納する配列を確保
ReDim lngDelete(1 To lngRows, 1 To 1)
Application.ScreenUpdating = False
'データ行数分繰り返し
For i = 1 To lngRows
'KeyがEmptyなら
If Trim(vntData(i, 1)) = Empty Then
'削除フラグを立てる
lngDelete(i, 1) = 1
'削除数をカウント
lngCount = lngCount + 1
End If
Next i
With rngList
'削除する行が合った場合
If lngCount > 0 Then
'削除フラグの配列をデータ列の右側に出力
.Offset(1, clngColumns).Resize(lngRows).Value = lngDelete
'削除フラグの列をKeyとして整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
'行の消去(空白行なら不要かも？)
' .Offset(lngRows - lngCount + 1).Resize(lngCount, clngColumns).ClearContents
''削除フラグの列を削除
.Offset(, clngColumns).EntireColumn.Delete
strProm = "処理が完了しました"
Else
strProm = "空白行が有りません"
End If
End With
Wayout:
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 10/4/18(日) 12:08 -
