|
ほとんど変えてません。
エクセル表内容の方に間違いがあるかも
しれないのでチェックします。お手数を
お掛けしておりますm(。_。;))m
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("H"))
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("List_Item"), strVal)
If IsError(varRet) Then Exit Function
If CLng(varRet) = 0 Then Exit Function
IsSheetExist = True
End Function
|
|