| |
私ならこんなコードにしますかな？
幾らか速いと思います
UserFormに以下のコントロールが配置されている物とします
1、CheckBox1〜CheckBox126でCaptionが比較する文字と同じ文字が設定されている物とします
上記の場合、★1のコードを使います
もし、CheckBoxのCaptionが比較する文字と違う文字の場合
デザインモードでCheckBoxのTagプロパティに比較する文字を設置します
例えば、CheckBox.Tag="a"の様にします
※実際のCheckBoxの数をコードの定数宣言
'CheckBoxの数
Const clngCheck As Long = 26
で設定して下さい
2、TextBox1〜TextBox4を配置します
※実際のTextBoxの数をコードの定数宣言
'TextBoxの数
Const clngText As Long = 4
で設定して下さい
3、CommandButtan1：実行ボタンを配置します
次に、操作するListはA〜T列迄で列見出しは無い物とします
UserFormを表示して、CheckBoxにチェックをいれCommandButton1を押すと
もし、チェックの数がclngText以下ならカウントと削除が行われます
UserFormのコードモジュールに以下を記述して下さい
Private Sub CommandButton1_Click()
'Listのデータ列数（A列〜T列）
Const clngColumns As Long = 20
'Listの中のKeyと成る列位置(基準列AからのB列列Offset)
Const clngKey As Long = 1
'CheckBoxの数
Const clngCheck As Long = 26
'TextBoxの数
Const clngText As Long = 4
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult As Range
Dim rngMark As Range
Dim vntData As Variant
Dim vntKeys As Variant
Dim vntResult As Variant
Dim lngCount As Long
Dim strProm As String
'Listの先頭セル位置を基準とする(データ先頭）
Set rngList = ActiveSheet.Range("A1")
'種別の値を取得
ReDim vntKeys(1 To 2, 1 To clngText)
lngCount = 0
For i = 1 To clngCheck
If Controls("CheckBox" & i).Value Then
lngCount = lngCount + 1
If lngCount > clngText Then
strProm = "チェックを出来る数は" & clngText & "個までです"
GoTo Wayout
End If
'★1比較するKeyがコントロールのCaptionと同じなら
'Captionから配列に移します
vntKeys(1, lngCount) = Controls("CheckBox" & i).Caption
'★2比較するKeyをコントロールのTagから配列に移します
' vntKeys(1, lngCount) = Controls("CheckBox" & i).Tag
End If
Next i
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, _
clngKey).End(xlUp).Row - .Row + 1
If lngRows <= 1 And IsEmpty(.Value) Then
strProm = "データが有りません"
GoTo Wayout
End If
'列データを配列に取得
vntData = .Offset(, clngKey).Resize(lngRows + 1).Value
'結果用配列を確保
ReDim vntResult(1 To lngRows, 1 To 1)
End With
'Key列に就いて繰り返し
lngCount = 0
For i = 1 To lngRows
'Keyの配列の先頭〜最終まで
For j = 1 To UBound(vntKeys, 2)
'先頭の1文字がKeyと一致するなら
If StrComp(Left(vntData(i, 1), 1), _
vntKeys(1, j), vbTextCompare) = 0 Then
Exit For
End If
Next j
'一致した場合
If j <= UBound(vntKeys, 2) Then
'種別のカウントを取る
vntKeys(2, j) = vntKeys(2, j) + 1
'結果用配列の現在位置にマークを入れる
vntResult(i, 1) = vntKeys(1, j)
Else
'マークを入れ入れない行をカウント
lngCount = lngCount + 1
End If
Next i
'取得した種別のカウントをTextBoxに転記
For i = 1 To clngText
Controls("TextBox" & i).Value _
= vntKeys(1, i) & " = " & vntKeys(2, i)
Next i
With rngList
'結果をListの最終行と最終行1列前に出力
.Offset(, clngColumns).Resize(lngRows).Value = vntResult
'選択した種別以外の物が有るなら
If lngCount > 0 Then
If MsgBox("選択された種別以外を削除しますか？", _
vbInformation + vbYesNo) = vbYes Then
'Listをマークを入れた行で整列
.Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'マークの無い行を削除
.Offset(lngRows - lngCount) _
.Resize(lngCount).EntireRow.Delete
End If
End If
End With
strProm = "処理が完了しました"
Wayout:
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
