Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1643 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【73049】テキストボックスの値を条件に一致する別シートのセルを元シートに返す ぶたごりら 12/11/1(木) 0:24 質問[未読]
【73050】Re:テキストボックスの値を条件に一致する... UO3 12/11/1(木) 9:40 発言[未読]
【73051】Re:テキストボックスの値を条件に一致する... UO3 12/11/1(木) 9:47 発言[未読]
【73052】Re:テキストボックスの値を条件に一致する... UO3 12/11/1(木) 10:05 発言[未読]
【73054】Re:テキストボックスの値を条件に一致する... ぶたごりら 12/11/1(木) 12:28 発言[未読]
【73055】Re:テキストボックスの値を条件に一致する... UO3 12/11/1(木) 14:09 発言[未読]
【73057】Re:テキストボックスの値を条件に一致する... ぶたごりら 12/11/1(木) 14:54 回答[未読]
【73058】Re:テキストボックスの値を条件に一致する... UO3 12/11/1(木) 15:06 発言[未読]
【73059】Re:テキストボックスの値を条件に一致する... ぶたごりら 12/11/1(木) 15:36 お礼[未読]
【73049】テキストボックスの値を条件に一致する別...
質問  ぶたごりら  - 12/11/1(木) 0:24 -
引用なし
パスワード
   いつもお世話になっています。

ユーザーフォームのテキストボックスに
「AAA」と入力して登録ボタンを押すと、
シート1のA列に条件に一致した全ての内容を書き込みたいです。

条件とはシート2に
A列　B列
AAA　あめ
AAA　うめ
BBB　こめ
CCC　さめ
CCC　きめ
とあり、シート1へテキストボックスの「AAA」に一致する
あめ
うめ
を表示させたいのです。

このテキストボックスは3個用意していますが登録ボタンは1個で、
それを押すと条件に当てはまる物がすべてシート1に書かれてくると嬉しいです。
「AAA」「CCC」で登録、と押すと
シート1に
あめ
うめ
さめ
きめ
のように出てくれる的な。

宜しくお願い致します。
【73050】Re:テキストボックスの値を条件に一致す...
発言  UO3  - 12/11/1(木) 9:40 -
引用なし
パスワード
   ▼ぶたごりら さん：

おはようございます
SHeet2の各列にタイトル行があれば、一発で抽出できますが、とりあえず
タイトル行がない場合のコードです。
（タイトル行をいれてループなしの処理をすることをおすすめしますが）

Private Sub CommandButton1_Click()
　　Dim s1 As String
　　Dim s2 As String
　　Dim s3 As String
　　Dim sx As String
　　Dim sh1 As Worksheet
　　Dim c As Range
　　Dim i As Long
　　
　　s1 = TextBox1.Value
　　s2 = TextBox2.Value
　　s3 = TextBox3.Value
　　
　　If Len(s1) > 0 Then sx = vbTab & s1
　　If Len(s2) > 0 Then sx = sx & vbTab & s2
　　If Len(s3) > 0 Then sx = sx & vbTab & s3
　　
　　If Len(sx) = 0 Then
　　　　MsgBox "抽出すべきキーが入力されていません"
　　Else
　　　　Set sh1 = Sheets("Sheet1")
　　　　sh1.Columns("A").ClearContents
　　　　With Sheets("Sheet2")
　　　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　　　　　　　If InStr(sx, c.Value) > 0 Then
　　　　　　　　　　i = i + 1
　　　　　　　　　　sh1.Cells(i, "A").Value = c.Offset(, 1).Value
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　End If
　　
End Sub
【73051】Re:テキストボックスの値を条件に一致す...
発言  UO3  - 12/11/1(木) 9:47 -
引用なし
パスワード
   ▼ぶたごりら さん：

↑のコードが、手抜きだったので再掲します。

Private Sub CommandButton1_Click()
　　Dim s1 As String
　　Dim s2 As String
　　Dim s3 As String
　　Dim sx As String
　　Dim sh1 As Worksheet
　　Dim c As Range
　　Dim i As Long
　　
　　s1 = TextBox1.Value
　　s2 = TextBox2.Value
　　s3 = TextBox3.Value
　　
　　If Len(s1) > 0 Then sx = vbTab & s1 & vbTab
　　If Len(s2) > 0 Then sx = sx & vbTab & s2 & vbTab
　　If Len(s3) > 0 Then sx = sx & vbTab & s3 & vbTab
　　
　　If Len(sx) = 0 Then
　　　　MsgBox "抽出すべきキーが入力されていません"
　　Else
　　　　Set sh1 = Sheets("Sheet1")
　　　　sh1.Columns("A").ClearContents
　　　　With Sheets("Sheet2")
　　　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　　　　　　　If InStr(sx, vbTab & c.Value & vbTab) > 0 Then
　　　　　　　　　　i = i + 1
　　　　　　　　　　sh1.Cells(i, "A").Value = c.Offset(, 1).Value
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　End If
　　
End Sub
【73052】Re:テキストボックスの値を条件に一致す...
発言  UO3  - 12/11/1(木) 10:05 -
引用なし
パスワード
   ▼ぶたごりら さん：

もし、Sheet2のＡ，Ｂ列の１行目にタイトル行があれば以下のような処理ができます。

Private Sub CommandButton1_Click()
　　Dim s1 As String
　　Dim s2 As String
　　Dim s3 As String
　　Dim sx As Variant
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim i As Long
　　Dim wCol As Long
　　
　　s1 = TextBox1.Value
　　s2 = TextBox2.Value
　　s3 = TextBox3.Value

　　If Len(s1 & s2 & s3) = 0 Then
　　　　MsgBox "抽出すべきキーが入力されていません"
　　　　Exit Sub
　　End If
　　
　　Application.ScreenUpdating = False
　　
　　Set sh1 = Sheets("Sheet1")
　　Set sh2 = Sheets("Sheet2")
　　
　　sh1.Columns("A").ClearContents
　　sh1.Range("A1").Value = sh2.Range("B1").Value
　　wCol = sh2.Cells(1, sh2.Columns.Count).End(xlToLeft).Column + 2
　　sh2.Cells(1, wCol) = sh2.Range("A1").Value
　　
　　i = 2
　　For Each sx In Array(s1, s2, s3)
　　　　If Len(sx) > 0 Then
　　　　　　sh2.Cells(i, wCol).Value = "'=" & sx
　　　　　　i = i + 1
　　　　End If
　　Next
　　
　　sh2.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, _
　　　　CriteriaRange:=sh2.Cells(1, wCol).CurrentRegion, _
　　　　CopyToRange:=sh1.Range("A1"), Unique:=False
　　
　　sh2.Columns(wCol).Clear
　　Application.ScreenUpdating = True
　　
End Sub
【73054】Re:テキストボックスの値を条件に一致す...
発言  ぶたごりら  - 12/11/1(木) 12:28 -
引用なし
パスワード
   ▼UO3 さん：
ありがとうございます、
Sheet2はタイトル列持っていますので、
最後に頂いた中身をコピーして処理しようとしているのですが、
何回もこのユーザーフォームは使いまわすのですが、
都度一番下にその「BBB」とかが入るようになるのですかね。

すみません、作成してもいないのに質問ばかりで。
とりあえず作ってみます、
【73055】Re:テキストボックスの値を条件に一致す...
発言  UO3  - 12/11/1(木) 14:09 -
引用なし
パスワード
   ▼ぶたごりら さん：

>都度一番下にその「BBB」とかが入るようになるのですかね。

？？
この意味がわからないのですが？
これが要件なんでしょうか？
【73057】Re:テキストボックスの値を条件に一致す...
回答  ぶたごりら  - 12/11/1(木) 14:54 -
引用なし
パスワード
   ▼UO3 さん：

すみません、１回だけその登録ボタンをおすのならいいのですが、
テキストボックスの中身を変えてまた登録を押したときに、
今までのが全部きえてしまいます。

今までのは残したままで、
追加していきたいのです。
【73058】Re:テキストボックスの値を条件に一致す...
発言  UO3  - 12/11/1(木) 15:06 -
引用なし
パスワード
   ▼ぶたごりら さん：

なりほど。

じゃぁ、以下でいかがでしょうか？

Private Sub CommandButton1_Click()
　　Dim s1 As String
　　Dim s2 As String
　　Dim s3 As String
　　Dim sx As Variant
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim i As Long
　　Dim wCol As Long
　　Dim z As Long
　　
　　s1 = TextBox1.Value
　　s2 = TextBox2.Value
　　s3 = TextBox3.Value

　　If Len(s1 & s2 & s3) = 0 Then
　　　　MsgBox "抽出すべきキーが入力されていません"
　　　　Exit Sub
　　End If
　
　　Application.ScreenUpdating = False
　
　　Set sh1 = Sheets("Sheet1")
　　Set sh2 = Sheets("Sheet2")
　
　　If IsEmpty(sh1.Range("A1").Value) Then
　　　　z = 1
　　Else
　　　　z = sh1.Range("A" & sh1.Rows.Count).End(xlUp).Row + 1
　　End If
　　
　　sh1.Range("A" & z).Value = sh2.Range("B1").Value
　　wCol = sh2.Cells(1, sh2.Columns.Count).End(xlToLeft).Column + 2
　　sh2.Cells(1, wCol) = sh2.Range("A1").Value
　
　　i = 2
　　For Each sx In Array(s1, s2, s3)
　　　　If Len(sx) > 0 Then
　　　　　　sh2.Cells(i, wCol).Value = "'=" & sx
　　　　　　i = i + 1
　　　　End If
　　Next
　
　　sh2.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, _
　　　　CriteriaRange:=sh2.Cells(1, wCol).CurrentRegion, _
　　　　CopyToRange:=sh1.Range("A" & z), Unique:=False
　　If z > 1 Then Rows(z).Delete
　　
　　sh2.Columns(wCol).Clear
　　Application.ScreenUpdating = True
　
End Sub
【73059】Re:テキストボックスの値を条件に一致す...
お礼  ぶたごりら  - 12/11/1(木) 15:36 -
引用なし
パスワード
   ▼UO3 さん：

おぉぉぉ！！できました！！
ありがとうございます！
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1643 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free