| |
以前UO3さんにお手伝いいただき一度は出来たのですが、
今度は書き込むシートをコンボボックスで選択制にして
それぞれ指定したシートに書き込むように変えたのですが、
そしたら１回登録する毎に１行消えてしまうようになりまして。
■ユーザーフォーム
テキストボックス1〜3
指定シート名
■シート3
A列 B列
AAA うめ
AAA
AAA
BBB あめ
CCC こめ
CCC
DDD つめ
とあり、テキストボックスにシート3の「AAA」などを入れ、
指定シート名（コンボボックス）に「シート1」と入れて登録すると
■シート1
A列 B列
AAA うめ
BBB あめ
と出、
指定シート名に「シート2」と入れて登録すると
■シート2
A列 B列
DDD つめ
CCC こめ
に入るようにしたかったのですが。
今ある中身は↓コレ↓になります。
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
|
|
ぶたごりら
- 12/11/5(月) 14:08 -
