| |
とりあえず、↓のような感じで。。。
ThisWorkbook に貼り付けてください。
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim varRet As Variant
Dim rngTarget As Range
Dim rngLoop As Range
Dim rngDel As Range
If ActiveWindow.SelectedSheets.Count <> 1 Then Exit Sub
If Not IsSheetExist(Sh.Name) Then Exit Sub
On Error Resume Next
Set rngTarget = Intersect(Target, Sh.Columns("G"))
On Error GoTo 0
If rngTarget Is Nothing Then Exit Sub
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For Each rngLoop In rngTarget
If Trim(rngLoop.Value) <> "" Then
If IsSheetExist(rngLoop.Value) Then
If Sh.Name <> rngLoop.Value Then
If rngDel Is Nothing Then
Set rngDel = rngLoop
Else
Set rngDel = Union(rngDel, rngLoop)
End If
rngLoop.EntireRow.Copy _
Destination:=Worksheets(rngLoop.Value).Cells(65536, 1).End(xlUp).Offset(1)
End If
End If
End If
Next rngLoop
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete Shift:=xlUp
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
'-- シート存在チェック
Function IsSheetExist(ByVal strVal As String) As Boolean
Dim varRet As Variant
IsSheetExist = False
varRet = Application.CountIf(Range("ListItem"), strVal)
If IsError(varRet) Then Exit Function
If CLng(varRet) = 0 Then Exit Function
IsSheetExist = True
End Function
前提として、
どのシートもレイアウトが同じ
どのシートも2行目以降にデータ移動
A列は、データがあれば必ず入力されている
ListItemという名前で、入力規則のリストが設定されている
>ボタンを置くのが一番賢明な方法でしょうか？
賢明かどうかは知りませんが、個人的に嫌だというだけです。
先にも書きましたが、手が滑って違うものを選択したときに、そのデータがどこに行ったか判らなくなりそうなので。
|
|
Asaki
- 04/4/5(月) 11:32 -
