[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『テーブルの列の空白以外の行をクリアしテーブル範囲を自動調整』（muu）
sheet1〜sheet10までにA4セルからテーブルがあります。
A B C D E F G
1
2
3
4 職種番号 職種 職員番号 退職日
この各sheet1〜10のテーブルで一括で下記作業を行いたいです。
1. G列が退職日となっており、退職日が入っている行をすべてクリアする
行ごと削除するとセルの条件付き書式が増殖するためクリアしたいです。
2. 職員番号、職種番号の順で昇順で並び替えをする。
クリアした空白行が一番下に移動する
3.一番下にきた空白行をテーブルの範囲から除外するため、テーブル範囲を自動調整する
この3つを一連の動作として行いたいです。
ご教示いただけないでしょうか？
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
何度かテストしてみたけど、条件付き書式が増殖することはなかったです。 再現手順を教えてもらえませんか？
参考までに行削除バージョンです。 シート１〜１０となっていますが、すべてのシーに同じ処理をさせるコードです。 必要なら、Forの後にIfで条件分岐させますが、正確なシート名がわからないと何もできなかったためすっ飛ばしました。 対象シート ＞ 対象外シート でしたら、対象外シート名だけ条件分岐してスルーさせればよさそうです。
Sub test()
Dim ws As Worksheet
Dim LO As ListObject
For Each ws In Sheets
'各シートにテーブルが1つしかないと想定
Set LO = ws.ListObjects(1)
'退職日の絞り込みと削除
With LO.DataBodyRange
.AutoFilter Field:=7, Criteria1:="<>" '退職日のみ表示
'行削除でも条件付き書式が増殖しなかったので、行削除にしました。
'ListObjectの行削除参考：https://qiita.com/tomikiya/items/d0d9f19221b8dcd93192
Application.DisplayAlerts = False
.Columns(7).SpecialCells(xlCellTypeVisible).Delete '行全体の削除
Application.DisplayAlerts = True
End With
'フィルタ解除
ws.ShowAllData
'並び替え
With LO.Sort
With .SortFields
.Clear
'職員番号昇順で文字列も数値とみなして並び替え
.Add _
Key:=LO.DataBodyRange(4), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
'職種番号昇順で文字列も数値とみなして並び替え
.Add _
Key:=LO.DataBodyRange(1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
End With
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next ws
MsgBox "退職者の削除と並び替えが完了しました。"
End Sub
（稲葉） 2020/12/19(土) 13:58
条件付き書式に上下のセルが異なる場合そのその境目のA列からV列まで罫線を引くようにしています。
式は=$B5=$B6でやっています。
これが行削除するとどんどん増えていきます。
すいません。
正確にはシート数は35くらいあってそのうち処理をしたいシートは5〜15及び35といった感じです。
ご教示いただいたコードを試してみたら、インデックスが有効範囲にありませんというエラーがでました。
（muu） 2020/12/19(土) 16:41
＞式は=$B5=$B6でやっています。 なるほど再現できました。ありがとうございます。 勉強になりました。
＞正確にはシート数は35くらいあってそのうち処理をしたいシートは5〜15及び35といった感じです 私にそのシートがどれかがわからないです。 名前で判断できなければ、決まった位置に特定の文言が入っている等でも構いません。 今回は、テーブルが存在しなければスルーで条件分岐しました。 しばらくパソコンみませんので、ご了承ください
Sub test()
Dim ws As Worksheet
Dim LO As ListObject
Dim tmpErr As Long
Dim msg(2) As String
For Each ws In Sheets
tmpErr = 0
'テーブルが存在すれば処理実行
If ws.ListObjects.Count > 0 Then
'各シートにテーブルが1つしかないと想定
Set LO = ws.ListObjects(1)
'退職日の絞り込みと削除
With LO.DataBodyRange
.AutoFilter Field:=7, Criteria1:="<>" '退職日のみ表示
On Error Resume Next
.SpecialCells(xlCellTypeVisible).ClearContents
tmpErr = Err.Number
On Error GoTo 0
End With
'フィルタ解除
ws.Activate
LO.Range.Activate 'リストオブジェクトの範囲内のセルがアクティブになっていないと、ShowAllDataでエラーになる
ws.ShowAllData
'並び替え
With LO.Sort
With .SortFields
.Clear
'職員番号昇順で文字列も数値とみなして並び替え
.Add _
Key:=LO.DataBodyRange(4), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
'職種番号昇順で文字列も数値とみなして並び替え
.Add _
Key:=LO.DataBodyRange(1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
End With
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'処理の結果を文字列で取得
If tmpErr > 0 Then
msg(0) = msg(0) & vbCrLf & ws.Name
Else
msg(1) = msg(1) & vbCrLf & ws.Name
End If
LO.Resize LO.Range.CurrentRegion
Else
msg(2) = msg(2) & vbCrLf & ws.Name
End If
Next ws
'処理結果の出力
MsgBox "■退職者がいませんでした" & msg(0) & vbCrLf & _
"■退職者の削除と並べ替えを実行しました" & msg(1) & vbCrLf & _
"■対象外のシートです。" & msg(2)
End Sub
（稲葉） 2020/12/19(土) 17:30
Sub test2()
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name Like "テーブル*" Then
With ws.ListObjects(1).Range
.AutoFilter Field:=7, Criteria1:="<>"
.Offset(1).EntireRow.Delete
.AutoFilter Field:=7
With .FormatConditions
.Delete
.Add(Type:=xlExpression, Formula1:="=$B4=$B5") _
.Borders(xlBottom).LineStyle = xlNone
End With
.Sort key1:=.Cells(1), Header:=xlYes
End With
End If
Next
End Sub
（マナ） 2020/12/19(土) 20:02
＞If ws.Name Like "テーブル*" Then
（マナ） 2020/12/19(土) 20:28
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.