12
anonymous No title
VBA
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

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

'リストデータを上から検索し、
'入力した文字と部分一致したデータをリストに表示する。
'入力セルを空白にした(削除した)場合はリストの全データを表示する。
'作業用シートは使用せず、セル一つ一つにリストを設定する



'対象セル以外のセルへの入力時はマクロを終了させる
If Target.Count > 1 Then Exit Sub
If Target.Row <= 4 Then Exit Sub
If Target.Column <> 1 Then Exit Sub

  
'イベントの抑制と対象セルの入力規則の削除
Application.EnableEvents = False
Target.Validation.Delete
  
  
    
'シートオブジェクト・レンジオブジェクトの宣言----------------------------------
Dim listWs As Worksheet
Dim listArea As Range
Dim lastRow As Long

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





'以降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を適用:かな,カナ 全角半角 大文字,小文字を区別しない様にするため)
'含まれていたら、Hits変数にカンマ区切りでヒットした文字列を連結していく。
'リストに設定できる文字列が255文字までなので、Hits変数を255文字まで切り取る。
'切り捨てた後に残った半端な文字列も切り捨てる。
'最後に、入力セルにHits変数をリストとして設定する。
 
If Target.Value <> "" Then
 Dim rng As Range
 Dim Hits As String
 Const chaLimit As Long = 255
 

  For Each rng In listArea
   If InStr(1, rng.Value, Target.Value, vbTextCompare) > 0 Then
    Hits = Hits & rng.Value & ","
    If Len(Hits) >= chaLimit Then Exit For
   End If
  Next
  
  If Hits <> "" Then
   Hits = Left(Hits, chaLimit)
   Hits = Left(Hits, InStrRev(Hits, ",") - 1)
   Target.Validation.Add Type:=xlValidateList, Formula1:=Hits
   Target.Validation.ShowError = False
  Else
   Target.Validation.Add Type:=xlValidateList, Formula1:="該当なし"
   Target.Validation.ShowError = False
  End If
 Target.Select
 SendKeys "%{Down}"
End If

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




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


End Sub
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
 
  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

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

Don't you submit code?
Submit
12