125678
anonymous No title
VBA
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)


'入力規則のリストにサジェスト機能を実装。

'入力した文字をリストデータから探し、部分一致したデータをリストとして表示する。
'入力セルを空白にした(削除した)場合はリストの全データを設定する。表示はしない。
'部分一致したデータを表示するために「検索候補シート」を作業用として使用。




'対象セル以外のセルへの入力時はマクロを終了させる
If Target.Count > 1 Then Exit Sub
If Target.Address <> Range("B5").Address Then Exit Sub


'イベントの抑制と対象セルの入力規則の削除
Application.EnableEvents = False
Target.Validation.Delete


'シートオブジェクト・レンジオブジェクトの宣言---------------------------------------------------
Dim listWs As Worksheet
Dim listArea As Range
Dim lastRow As Long
Dim hitWs As Worksheet
Dim hitArea As Range


Set listWs = Sheets("リスト")
lastRow = listWs.Cells(Rows.Count, 1).End(xlUp).Row
Set listArea = listWs.Range(listWs.Cells(2, 1), listWs.Cells(lastRow, 1))

Set hitWs = Sheets("検索候補")
Set hitArea = hitWs.Range("A:A")
hitArea.ClearContents
'-----------------------------------------------------------------------------------------------


'以降3つに分岐
'①そもそも入力した文字がリストのデータのいずれかと完全一致している場合
  'リストを表示せずに終了

'②入力セルが空白の場合
  'リストの全データを設定する。表示はしない

'③上記以外
  '部分一致したリストを表示させる

'①----------------------------------------------------------------------------------------------
If Not IsError(Application.Match(Target.Value, listArea, 0)) Then
 Application.EnableEvents = True
 Exit Sub
End If
'------------------------------------------------------------------------------------------------

'②----------------------------------------------------------------------------------------------
If Target.Value = "" Then
 Target.Validation.Add Type:=xlValidateList, Formula1:="=" & listArea.Address(external:=True)
 Target.Validation.ShowError = False
 Application.EnableEvents = True
 Exit Sub
End If
'------------------------------------------------------------------------------------------------

'③----------------------------------------------------------------------------------------------
'方法
'InStr関数を使用し、リストデータ内に入力した文字が含まれているか上から確認していく。
'※InStr関数にはvbTextCompareを適用(カナ,かな 全角半角 大文字,小文字を区別しないようにするため)
'含まれていたら、そのデータを「検索候補シートのA列」に列記していく。
'最後に、入力セルに「検索候補シートのA列」をリストとして設定する。

If Target.Value <> "" Then
 Dim rng As Range
 Dim cnt As Long
 Dim Hits As String
 
  For Each rng In listArea
   If InStr(1, rng.Value, Target.Value, vbTextCompare) > 0 Then
    cnt = cnt + 1
    hitArea(cnt).Value = rng.Value
   End If
  Next
  Target.Validation.Add Type:=xlValidateList, Formula1:="=" & hitArea.Address(external:=True)
  Target.Validation.ShowError = False
End If

'-----------------------------------------------------------------------------------------------


'入力セルを選択し、リストを表示する
Target.Select
SendKeys "%{Down}"

'イベント抑制の解除
Application.EnableEvents = True

End Sub
anonymous No title
VBA
Option Explicit
Sub 部分和問題()
Range("C:C").ClearContents
Dim n As Long
Dim a As Variant
Dim i As Long
Dim j As Long

'n個の整数を配列化--------------------------------------
n = Cells(Rows.Count, 1).End(xlUp).Row
ReDim a(n - 1) As Variant
For i = 0 To n - 1
 a(i) = Cells(i + 1, 1)
Next
'-------------------------------------------------------


'求める総和をxに代入しxの大きさの配列pを用意-----------
'p(0) は初期値0 それ以外の要素は初期値-1
Dim x As Long '総和
Dim p As Variant
x = Range("B1").Value
ReDim p(x) As Variant
p(0) = 0
For i = 1 To x
 p(i) = -1
Next
'-------------------------------------------------------


'配列pに部分和を格納していく----------------------------
'p(x)に値が格納され次第「outputPoint」へ飛ぶ
For i = 0 To UBound(a)
 For j = UBound(p) To 0 Step -1
  If p(j) <> -1 And j + a(i) <= x Then
   If p(j + a(i)) = -1 Then
    p(j + a(i)) = a(i)
   End If
   If p(x) <> -1 Then GoTo outputPoint
  End If
 Next j
Next i
'-------------------------------------------------------


'p(x)に値が格納されなかったら解なし
MsgBox "解なし"
Exit Sub
'-------------------------------------------------------


outputPoint:
'outputPoint--------------------------------------------
'配列pに格納された値から部分集合を求める
'方法:
'①P(x)の値が部分集合の一つの値となる
'②次にp(x-p(x))が部分集合の一つの値となる
'以降繰り返してp(x) = x となったら終了
Dim Perts() As Variant
Dim v As Long
Dim cnt As Long
v = x
Do
 ReDim Preserve Perts(cnt) As Variant
 If p(v) = v Then
  Perts(cnt) = v
  Exit Do
 Else
  Perts(cnt) = p(v)
  v = v - p(v)
  cnt = cnt + 1
 End If
Loop
Perts = WorksheetFunction.Transpose(Perts)
Range("C1").Resize(cnt + 1) = Perts
MsgBox "求まりました。"
End Sub

anonymous No title
VBA
Option Explicit
Sub 部分和問題()
Range("C:C").ClearContents
Dim n As Long
Dim a As Variant
Dim i As Long
Dim j As Long
'n個の整数を配列化--------------------------------------
n = Cells(Rows.Count, 1).End(xlUp).Row
ReDim a(n - 1) As Variant
For i = 0 To n - 1
 a(i) = Cells(i + 1, 1)
Next
'-------------------------------------------------------
'求める総和をxに代入しxの大きさの配列pを用意-----------
'p(0) は初期値0 それ以外の要素は初期値-1
Dim x As Long '総和
Dim p As Variant
x = Range("B1").Value
ReDim p(x) As Variant
p(0) = 0
For i = 1 To x
 p(i) = -1
Next
'-------------------------------------------------------
'配列pに部分和を格納していく----------------------------
'p(x)に値が格納され次第「outputPoint」へ飛ぶ
For i = 0 To UBound(a)
 For j = UBound(p) To 0 Step -1
  If p(j) <> -1 And j + a(i) <= x Then
   If p(j + a(i)) = -1 Then
    p(j + a(i)) = a(i)
   End If
   If p(x) <> -1 Then GoTo outputPoint
  End If
 Next j
Next i
'-------------------------------------------------------

'p(x)に値が格納されなかったら解なし
MsgBox "解なし"
Exit Sub

'-------------------------------------------------------


outputPoint:
'outputPoint--------------------------------------------
'配列pに格納された値から部分集合を求める
'方法:
'①P(x)の値が部分集合の一つの値となる
'②次にp(x-p(x))が部分集合の一つの値となる
'以降繰り返してp(x) = x となったら終了
Dim Perts() As Variant
Dim v As Long
Dim cnt As Long
v = x
Do
 ReDim Preserve Perts(cnt) As Variant
 If p(v) = v Then
  Perts(cnt) = v
  Exit Do
 Else
  Perts(cnt) = p(v)
  v = v - p(v)
  cnt = cnt + 1
 End If
Loop

Perts = WorksheetFunction.Transpose(Perts)
Range("B1").Resize(cnt + 1) = Perts
MsgBox "求まりました。"
End Sub
anonymous No title
VBA
Option Explicit
Sub 部分和問題()
Range("B:B").ClearContents
Dim n As Long
Dim a As Variant
Dim i As Long
Dim j As Long
'n個の整数を配列化--------------------------------------
n = Cells(Rows.Count, 1).End(xlUp).Row
ReDim a(n - 1) As Variant
For i = 0 To n - 1
 a(i) = Cells(i + 1, 1)
Next
'-------------------------------------------------------
'求める総和をxに代入しxの大きさの配列pを用意-----------
'p(0) は初期値0 それ以外の要素は初期値-1
Dim x As Long '総和
Dim p As Variant
x = Range("B1").Value
ReDim p(x) As Variant
p(0) = 0
For i = 1 To x
 p(i) = -1
Next
'-------------------------------------------------------
'配列pに部分和を格納していく----------------------------
'p(x)に値が格納され次第「outputPoint」へ飛ぶ
For i = 0 To UBound(a)
 For j = UBound(p) To 0 Step -1
  If p(j) <> -1 And j + a(i) <= x Then
   If p(j + a(i)) = -1 Then
    p(j + a(i)) = a(i)
   End If
   If p(x) <> -1 Then GoTo outputPoint
  End If
 Next j
Next i
'-------------------------------------------------------

'p(x)に値が格納されなかったら解なし
MsgBox "解なし"
Exit Sub

'-------------------------------------------------------


outputPoint:
'outputPoint--------------------------------------------
'配列pに格納された値から部分集合を求める
'方法:
'①P(x)の値が部分集合の一つの値となる
'②次にp(x-p(x))が部分集合の一つの値となる
'以降繰り返してp(x) = x となったら終了

Dim Perts() As Variant
Dim v As Long
Dim cnt As Long
v = x
Do
 ReDim Preserve Perts(cnt) As Variant
 If p(v) = v Then
  Perts(cnt) = v
  Exit Do
 Else
  Perts(cnt) = p(v)
  v = v - p(v)
  cnt = cnt + 1
 End If
Loop
Range("B:B").ClearContents
Perts = WorksheetFunction.Transpose(Perts)
Range("B1").Resize(cnt + 1) = Perts
MsgBox "求まりました。"
End Sub
anonymous No title
VBA
Option Explicit
Sub 部分和問題()
Range("B:B").ClearContents
Dim n As Long
Dim a As Variant
Dim i As Long
Dim j As Long
'n個の整数を配列化--------------------------------------
n = Cells(Rows.Count, 1).End(xlUp).Row
ReDim a(n - 1) As Variant
For i = 0 To n - 1
 a(i) = Cells(i + 1, 1)
Next
'-------------------------------------------------------
'求める総和をxに代入しxの大きさの配列pを用意-----------
'p(0) は初期値0 それ以外の要素は初期値-1
Dim x As Long '総和
Dim p As Variant
x = 410636
ReDim p(x) As Variant
p(0) = 0
For i = 1 To x
 p(i) = -1
Next
'-------------------------------------------------------
'配列pに部分和を格納していく----------------------------
'p(x)に値が格納され次第「outputPoint」へ飛ぶ
For i = 0 To UBound(a)
 For j = UBound(p) To 0 Step -1
  If p(j) <> -1 And j + a(i) <= x Then
   If p(j + a(i)) = -1 Then
    p(j + a(i)) = a(i)
   End If
   If p(x) <> -1 Then GoTo outputPoint
  End If
 Next j
Next i
'-------------------------------------------------------
'p(x)に値が格納されなかったら解なし
MsgBox "解なし"
Exit Sub
'outputPoint--------------------------------------------
'配列pに格納された値から部分集合を求める
'方法:
'①P(x)の値が部分集合の一つの値となる
'②次にp(x-p(x))が部分集合の一つの値となる
'以降繰り返してp(x) = x となったら終了
outputPoint:
Dim Perts() As Variant
Dim v As Long
Dim cnt As Long
v = x
Do
 ReDim Preserve Perts(cnt) As Variant
 If p(v) = v Then
  Perts(cnt) = v
  Exit Do
 Else
  Perts(cnt) = p(v)
  v = v - p(v)
  cnt = cnt + 1
 End If
Loop
Range("B:B").ClearContents
Perts = WorksheetFunction.Transpose(Perts)
Range("B1").Resize(cnt + 1) = Perts
MsgBox "求まりました。"
End Sub
anonymous No title
VBA
Option Explicit
Sub 部分和問題()
Range("B:B").ClearContents
Dim n As Long
Dim a As Variant
Dim i As Long
Dim j As Long

'n個の整数を配列化--------------------------------------
n = Cells(Rows.Count, 1).End(xlUp).Row
ReDim a(n - 1) As Variant
For i = 0 To n - 1
 a(i) = Cells(i + 1, 1)
Next
'-------------------------------------------------------

'求める総和をxに代入しxの大きさの配列pを用意-----------
'p(0) は初期値0 それ以外の要素は初期値-1
Dim x As Long '総和
Dim p As Variant
x = 410636
ReDim p(x) As Variant
p(0) = 0
For i = 1 To x
 p(i) = -1
Next
'-------------------------------------------------------
'配列pに部分和を格納していく----------------------------
'p(x)に値が格納され次第「outputPoint」へ飛ぶ
For i = UBound(a) To 0 Step -1
 For j = UBound(p) To 0 Step -1
  If p(j) <> -1 And j + a(i) <= x Then
   If p(j + a(i)) = -1 Then
    p(j + a(i)) = a(i)
   End If
   If p(x) <> -1 Then GoTo outputPoint
  End If
 Next j
Next i
'-------------------------------------------------------
'p(x)に値が格納されなかったら解なし
MsgBox "解なし"
Exit Sub

'outputPoint--------------------------------------------
'配列pに格納された値から部分集合を求める
'方法:
'①P(x)の値が部分集合の一つの値となる
'②次にp(x-p(x))が部分集合の一つの値となる
'以降繰り返してp(x) = x となったら終了
outputPoint:
Dim Perts() As Variant
Dim v As Long
Dim cnt As Long
v = x
Do
 ReDim Preserve Perts(cnt) As Variant
 If p(v) = v Then
  Perts(cnt) = v
  Exit Do
 Else
  Perts(cnt) = p(v)
  v = v - p(v)
  cnt = cnt + 1
 End If
Loop
Range("B:B").ClearContents
Perts = WorksheetFunction.Transpose(Perts)
Range("B1").Resize(cnt + 1) = Perts
MsgBox "求まりました。"
End Sub
anonymous No title
VBA
Option Explicit

Private Sub CommandButton1_Click()
    Dim lastRow As Long
    Dim myData, myData2(), myno
    Dim i As Long, j As Long, cn As Long
    
    ' If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Then End
    
    With Worksheets("Sheet1")
    
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        myData = .Range(.Cells(1, 1), .Cells(lastRow, 6)).Value
    End With
    
    ReDim myData2(1 To lastRow, 1 To 6)
    ReDim myData2(1 To 6)
    For i = LBound(myData) To UBound(myData)
    
        If myData(i, 4) Like "?" & TextBox1.Value & "*" And myData(i, 6) Like "*" & TextBox2.Value & "*" And myData(i, 2) Like "*" & TextBox3.Value & "*" Then
        
            cn = cn + 1
    
            ListBox1.AddItem  '★追加
            ListBox1.List(cn - 1, 1) = myData(i, 1) '★追加
            ListBox1.List(cn - 1, 2) = myData(i, 2) '★追加
            ListBox1.List(cn - 1, 3) = myData(i, 3) '★追加
            ListBox1.List(cn - 1, 4) = myData(i, 4) '★追加
        End If
    
    Next
    
    With ListBox1
        .ColumnCount = 5
        .ColumnWidths = "40;80;60;50;170"
        '.List = myData2 '★不要
    End With
    
End Sub



anonymous No title
VBA
Option Explicit

Private Sub CommandButton1_Click()
Dim lastRow As Long
Dim myData, myData2(), myno
Dim i As Long, j As Long, cn As Long

' If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Then End

With Worksheets("Sheet1")

lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
myData = .Range(.Cells(1, 1), .Cells(lastRow, 6)).Value
End With

ReDim myData2(1 To lastRow, 1 To 6)
ReDim myData2(1 To 6)
For i = LBound(myData) To UBound(myData)

If myData(i, 4) Like "?" & TextBox1.Value & "*" And myData(i, 6) Like "*" & TextBox2.Value & "*" And myData(i, 2) Like "*" & TextBox3.Value & "*" Then
cn = cn + 1

ListBox1.AddItem  '★追加
ListBox1.List(cn - 1, 1) = myData(i, 1) '★追加
ListBox1.List(cn - 1, 2) = myData(i, 2) '★追加
ListBox1.List(cn - 1, 3) = myData(i, 3) '★追加
ListBox1.List(cn - 1, 4) = myData(i, 4) '★追加
End If

Next

With ListBox1
.ColumnCount = 5
.ColumnWidths = "40;80;60;50;170"
'.List = myData2 '★不要
End With

End Sub

anonymous 投稿テスト コメントの修正
VBA
Sub test()
    Dim 一覧() As String

    '処理の都合で最初の一人だけ名前をセットしておく '
    ReDim Preserve 一覧(10, 0)
    一覧(0, 0) = Range("B2")

    For r = 2 To Cells(Rows.Count, 2).End(xlUp).Row  '2行目から最後まで調べる '
        名前 = Cells(r, "B")  'B列から名前を取り出す '

        '名前が一覧の配列の中にあるか調べる '
        n = -1
        For i = 0 To UBound(一覧, 2)
            If 一覧(0, i) = 名前 Then n = i
        Next i

        'なかったらその人の行を追加 '
        If n = -1 Then
            n = UBound(一覧, 2) + 1
            ReDim Preserve 一覧(10, n)
            一覧(0, n) = 名前
        End If

        'D列とF列の数字の範囲に札を持っているフラグをセット '
        For i = Cells(r, "D") To Cells(r, "F")
            一覧(i, n) = 1
        Next i
    Next r

    '結果を整理して出力 '
    For r = 0 To UBound(一覧, 2)
        '一人ずつフラグを見ながら、変数sに数字をまとめる '
        s = ""
        For i = 1 To 10
            If 一覧(i, r) <> "" Then s = s & "、" & i  'どんどん追加 '
        Next i
        s = Mid(s, 2, 30)  '先頭の読点を消す '
        Debug.Print 一覧(0, r), s
    Next r

End Sub
anonymous No title
VBA
Sub test()
    Dim 一覧() As String

    '処理の都合で最初の一人だけ名前をセットしておく
    ReDim Preserve 一覧(10, 0)
    一覧(0, 0) = Range("B2")

    For r = 2 To Cells(Rows.Count, 2).End(xlUp).Row  '2行目から最後まで調べる
        名前 = Cells(r, "B")  'B列から名前を取り出す

        '名前が一覧の配列の中にあるか調べる
        n = -1
        For i = 0 To UBound(一覧, 2)
            If 一覧(0, i) = 名前 Then n = i
        Next i

        'なかったらその人の行を追加
        If n = -1 Then
            n = UBound(一覧, 2) + 1
            ReDim Preserve 一覧(10, n)
            一覧(0, n) = 名前
        End If

        'D列とF列の数字の範囲に札を持っているフラグをセット
        For i = Cells(r, "D") To Cells(r, "F")
            一覧(i, n) = 1
        Next i
    Next r

    '結果を整理して出力
    For r = 0 To UBound(一覧, 2)
        '一人ずつフラグを見ながら、変数sに数字をまとめる
        s = ""
        For i = 1 To 10
            If 一覧(i, r) <> "" Then s = s & "、" & i  'どんどん追加
        Next i
        s = Mid(s, 2, 30)  '先頭の読点を消す
        Debug.Print 一覧(0, r), s
    Next r

End Sub
Don't you submit code?
Submit
125678