| |
こんにちは。
入力ダイアログってのが良くわかんなかったんで、フォームを使ってみました。
フォームにTextBox1〜3まで３個とコマンドボタンを１つ作ってください。
尚、「２つあるいは３つの文字を入力し」ですが、同じ行に数種類の文字があった場合、ダブリチェックは入れていませんので、同じ行を何度か抽出してしまいます。
また、コピー先のシートのセルに赤く塗られたまま貼りつけています。色が不用でしたら後で色を消す必要もあります。
最後に
貼りつけ先の最終行をA列で判定していますので、コピー元シートのＡ列は空きが無い事が条件となっています。
Private Sub CommandButton1_Click()
Dim UdAd As String, SRow As Long, ERow As Long, ECol As Integer
Dim Fig As Boolean, CCel As Range, PastSheet As Worksheet
Dim PWsEndR As Long
UdAd = ActiveSheet.UsedRange.Address(0, 0)
SRow = Range(UdAd).Row
ERow = Range(UdAd).Cells(Range(UdAd).Count).Row
Set PastSheet = Worksheets("Sheet2")
SachCnt = 0
For i = SRow To ERow
With Range("A" & i & ":IV" & i)
For Ti = 1 To 3
Flg = False
If Me.Controls("TextBox" & Ti).Value <> "" Then
SachMj = Me.Controls("TextBox" & Ti).Value
Set CCel = .Find(SachMj, After:=Range("IV" & i), _
LookAt:=xlWhole, MatchCase:=True)
If Not CCel Is Nothing Then
SaveAd = CCel.Address
Flg = True
Do
CCel.Interior.ColorIndex = 3
Set CCel = .FindNext(CCel)
Loop Until SaveAd = CCel.Address
End If
End If
If Flg = True Then
SachCnt = SachCnt + 1
PWsEndR = PastSheet.Cells(Rows.Count, "A").End(xlUp).Row
If SachCnt <> 1 Then
PWsEndR = PWsEndR + 1
End If
Range(SaveAd).EntireRow.Select
Range(SaveAd).EntireRow.Copy Destination:=PastSheet.Rows(PWsEndR)
End If
Next
End With
Next
Set CCel = Nothing
Set PastSheet = Nothing
Unload Me
End Sub
|
|
Jaka
- 03/3/28(金) 10:19 -
