| |
▼HM さん：
こんにちは。
>指定した値や文字があるセルの行を全て別のシートにコピーするマクロを作りたいのですが・・。どなたか教えてください。
以下のコードは"aaa"でアクティブシートを検索し、該当するセルを含む行を
左隣のシートにコピーするコード例です。試してみて下さい。
'=================================================================
Sub main()
Dim f_value As Variant
Dim find_cell As Range
Dim copy_row As Range
f_value = "aaa" '検索する値を入れる
Set copy_row = Nothing
Set find_cell = get_findcell(f_value, ActiveSheet.Cells)
Do While Not find_cell Is Nothing
If Not copy_row Is Nothing Then
If Application.Intersect(copy_row, find_cell.EntireRow) Is Nothing Then
Set copy_row = Union(copy_row, find_cell.EntireRow)
End If
Else
Set copy_row = find_cell.EntireRow
End If
Set find_cell = get_findcell() '次の検索
Loop
If Not copy_row Is Nothing Then
copy_row.Copy ActiveSheet.Next.Range("a1")
End If
Set copy_row = Nothing
End Sub
'========================================================================
Function get_findcell(Optional f_v As Variant = "", Optional rng As Range = Nothing, Optional 方法 As Long = 1) As Range
'指定された値でセル範囲を検索し､該当するセルを取得する
'input : f_v 検索する値
' rng 検索する範囲
' 方法: :検索方法 1-完全一致 2-部分一致
'output:get_findcell 見つかったセル(見つからなかったときはNothingが返る)
Static 検索範囲 As Range
Static 最初に見つかったセル As Range
Static 直前に見つかったセル As Range
If Not rng Is Nothing Then
Set 検索範囲 = rng
End If
If f_v <> "" Then
Set get_findcell = 検索範囲.Find(f_v, , xlValue, 方法)
If Not get_findcell Is Nothing Then
Set 最初に見つかったセル = get_findcell
Set 直前に見つかったセル = get_findcell
End If
Else
Set get_findcell = 検索範囲.FindNext(直前に見つかったセル)
If get_findcell.Address = 最初に見つかったセル.Address Then
Set get_findcell = Nothing
Else
Set 直前に見つかったセル = get_findcell
End If
End If
End Function
|
|
