Excel VBA質問箱 IV

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

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


1624 / 13646 ツリー ←次へ | 前へ→

【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のA,B列の1行目にタイトル行があれば以下のような処理ができます。

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 さん:

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

今までのは残したままで、
追加していきたいのです。

【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 さん:

おぉぉぉ!!できました!!
ありがとうございます!

1624 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free