| |
▼ぶたごりら さん：
もし、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
|
|
UO3
- 12/11/1(木) 10:05 -
