| |
▼ぶたごりら さん：
なりほど。
じゃぁ、以下でいかがでしょうか？
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
|
|
UO3
- 12/11/1(木) 15:06 -
