Excel VBA質問箱 IV

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

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


17062 / 76732 ←次へ | 前へ→

【65130】Re:整列について
回答  Hirofumi  - 10/4/18(日) 12:08 -

引用なし
パスワード
   こんなでは?

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
3 hits

【65118】整列について ネガメジン 10/4/17(土) 18:11 質問
【65119】Re:整列について teian 10/4/17(土) 18:35 発言
【65121】Re:整列について ネガメジン 10/4/17(土) 21:30 質問
【65122】Re:整列について teian 10/4/17(土) 22:19 発言
【65123】Re:整列について ネガメジン 10/4/17(土) 22:52 質問
【65128】Re:整列について teian 10/4/18(日) 11:38 発言
【65131】Re:整列について ichinose 10/4/18(日) 12:20 発言
【65136】Re:整列について teian 10/4/18(日) 17:01 発言
【65130】Re:整列について Hirofumi 10/4/18(日) 12:08 回答
【65125】Re:整列について ichinose 10/4/18(日) 9:22 発言
【65137】Re:整列について ネガメジン 10/4/18(日) 17:01 質問
【65139】Re:整列について teian 10/4/18(日) 17:25 発言
【65146】Re:整列について ネガメジン 10/4/19(月) 11:17 お礼
【65145】Re:整列について ネガメジン 10/4/19(月) 11:08 お礼

17062 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free