重複セルに連番をふって1以外削除するマクロ
を示す。
■LibreOffice-VBA 重複セルに連番をふって1以外削除するマクロ
Option VBASupport 1
Sub sample16()
Dim MR As Long
Dim MC As Long
Dim DP As Long
Dim i As Long
Dim j As Long
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
MC = Cells(1, Columns.Count).End(xlToLeft).Column 'ω'1:1,最終列
DP = 15 'ω'重複セル削除列指定
j = 1
Range(Cells(1, 1), Cells(MR, MC)).Sort _
Key1:=Cells(1, DP), Order1:=xlAscending, _
Header:=xlYes
ZZ = Range(Cells(1, MC + 1), Cells(MR, MC + 1))
AA = Range(Cells(1, DP), Cells(MR + 1, DP))
For i =2 To MR
ZZ(i, 1) = j
j = j + 1
If AA(i, 1) <> AA(i + 1, 1) Then
j = 1
End If
Next i
Range(Cells(1, MC + 1), Cells(MR, MC + 1)) = ZZ
Cells(1, MC + 1) = "削除"
Cells(1, 1).AutoFilter Field:=MC + 1, Criteria1:=1
フィルタ削除01
End Sub
※[1.] LibreOffice BasicでVBA使用に必要。※[4.~8.] 変数宣言。
※[10.~11.] セル指定範囲取得。■過去記事■
※[12.] 重複セル削除列、15列目(O列)指定。
※[15.~17.] 重複セル並べ替え。■過去記事■
※[19.] 配列ZZ。連番値格納用。空白セルを仮格納。
※[20.] 配列AA。15列目(O列)の値を格納。
※[21.~27] For Next。2行目から最終行まで処理。
If Then End If。次セルと数値比較して
・同じ場合 j = j + 1 (連番カウント)
・違う場合 j = 1 (連番リセット)
※[29.] 配列ZZの連番値を最終列に格納。
※[31.] 連番列先頭行に名前「削除」をつける。
※[32.~33.] オートフィルタ。1以外削除。■過去記事■
「フィルタ削除01」部分
Option VBASupport 1
Sub フィルタ削除01()
Dim SN1 As String 'ω'以下ﾌｨﾙﾀ非該当行削除
SN1 = ActiveSheet.Name
Cells.Select
Worksheets(SN1).Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "削除01"
Dim DM1 as object
Dim DP1 as object
DM1 = ThisComponent.CurrentController.Frame
DP1 = createUnoService("com.sun.star.frame.DispatchHelper")
DP1.executeDispatch(DM1, ".uno:Paste", "", 0, Array())
Worksheets(SN1).AutoFilterMode = False
Worksheets(SN1).Rows.Hidden = False
Sheets(SN1).Cells.Clear
Worksheets("削除01").Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets(SN1).Range("A1").PasteSpecial Paste:=xlPasteAll
Sheets("削除01").Delete
End Sub
※ペーストはLibreOffice流のコード使用。■マクロ実行対象
「部品データ_191108.ods」の「部品表」シート。15列目(O列)。
■マクロ実行結果
実行すると、「AA」、「旧方式」、「新方式」、「」(ブランク)の連番「1」以外の重複セルはすべて削除される。
■補足-エクセルVBA-重複セルに連番をふって1以外削除するマクロ
Sub sample16e()
Dim MR As Long
Dim MC As Long
Dim DP As Long
Dim i As Long
Dim j As Long
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
MC = Cells(1, Columns.Count).End(xlToLeft).Column 'ω'1:1,最終列
DP = 15 'ω'重複セル削除列指定
j = 1
Range(Cells(1, 1), Cells(MR, MC)).Sort _
Key1:=Cells(1, DP), Order1:=xlAscending, _
Header:=xlYes
ZZ = Range(Cells(1, MC + 1), Cells(MR, MC + 1))
AA = Range(Cells(1, DP), Cells(MR + 1, DP))
For i =2 To MR
ZZ(i, 1) = j
j = j + 1
If AA(i, 1) <> AA(i + 1, 1) Then
j = 1
End If
Next i
Range(Cells(1, MC + 1), Cells(MR, MC + 1)) = ZZ
Cells(1, MC + 1) = "削除"
Cells(1, 1).AutoFilter Field:=MC + 1, Criteria1:=1
フィルタ削除01
End Sub
※「Option VBASupport 1」なし。Sub フィルタ削除01()
Dim SN1 As String 'ω'以下ﾌｨﾙﾀ非該当行削除
SN1 = ActiveSheet.Name
Worksheets(SN1).Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "削除01"
Worksheets("削除01").Range("A1").PasteSpecial Paste:=xlPasteAll
Worksheets(SN1).AutoFilterMode = False
Sheets(SN1).Cells.Clear
Worksheets("削除01").Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets(SN1).Range("A1").PasteSpecial Paste:=xlPasteAll
Sheets("削除01").Delete
End Sub
※LibreOffice流とはPasteやxlCellTypeVisibleコピーが異なる。■あとがき
エクセルVBAの重複セルに連番をふって1以外削除するマクロ
LibreOffice Basicでも使用できることを確認した。
「重複セルの最大値を残したい」など、
優先順位ある場合並べ替えに「Key2:=」追加する。
■LibreOffice-VBA セルの並び替え-ソート 昇順-降順-範囲指定
今回使用した配列について補足。
ZZ(配列名)[〇行、〇列]とする。
配列ZZには最初、仮の空白セルを
ZZ[1,1]～ZZ[MR,1]まで格納。
⇒forループでZZ[2,1]=1、ZZ[3,1]=2、…1つずつ格納。
⇒ZZ[1,1]～ZZ[MR,1]の値をシート最終列の各セルに格納した。
配列AAは
AA[1,1]～AA[MR+1,1]に重複セルの値を格納。
⇒Ifで値を比較した。
MRが+1なのは最後のIf比較で次セル値が必要なため。
今回配列は1列目のみ使用したが、
セルを範囲指定して2列目以降にも格納可能。
配列を使うとシートに1回のアクセスで
まとめて値を入力できる。
セル1つ1つに値を入力して
その回数分シートにアクセスするより
処理速度がはやい。
以上。
