LibreOffice-VBA 重複セルに連番をふって1以外削除するマクロ

LibreOfficeでVBAマクロ実行。今回は
重複セルに連番をふって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つに値を入力して
その回数分シートにアクセスするより
処理速度がはやい。
以上。