[求助] 修改VBA

shao81811

求助各位大神

附件中的VBA有待完善，我先说明下附件内容：
首先根据黄色的5张表取得&废弃&移动&返却&仕损的内容，更新蓝色工作表<固定资产管理台帐>（后续简称台帐）,
①黄色工作表<取得>的A列到Q列的格式和内容一样，需要将取得表里“A列到Q列”的内容增加到台帐里即可，
②黄色工作表<移动>在台帐里就有，只是将此表P列“TO所在地和Q列“所在地代码”，更新到台帐里O列“所在地”和P列“所在地代码”
③黄色工作表<废弃>、<返却>、<仕损>表里的内容直接删除即可
需要完善的是第二项，运行附件里的VBA是，就会如同①的描述，会在台帐里重复追加一条。大神一看VBA就知道了。
实际上是需要按第二项红色字体的要求改一下VBA.

shao81811

大神们求帮助！！！

shao81811

求助！求助！求助！求助！求助！求助！求助！求助！求助！

shao81811

请大神们帮忙看看，如何修改“”Sheets("移動").Activate   Call 增加“”。如上文所述，移动表里的内容在<台帐>里已存在，指示所在地不同了，只要把<移动>表里"to 所在地“和“所在地代码“更新台帐里的“所在地”和“所在地代码”即可。

shao81811

求助，各位大神快来看看

shao81811

Sub zj()
    Sheets("取得").Activate
    Call 增加
    Sheets("移動").Activate
    Call 增加
    Sheets("廃棄").Activate
    Call 减少
    Sheets("返却").Activate
    Call 减少
    Sheets("仕損").Activate
    Call 减少
End Sub
Sub 增加()
    Dim brr(), arr(), dic As Object, i As Long, j As Long, a
    Set dic = CreateObject("scripting.dictionary")
   
   
    brr = Sheets("固定資産管理台帳").Range(Sheets("固定資産管理台帳").[d2], Sheets("固定資産管理台帳").Cells(100000, 4).End(3)).Value
    For i = 1 To Sheets("固定資産管理台帳").Cells(100000, 4).End(3).Row - 1
        dic(brr(i, 1)) = i + 1
    Next
     On Error GoTo a
    arr = ActiveSheet.Range([d2], Cells(1000000, 4).End(3)).Value
    For j = 1 To ActiveSheet.Cells(1000000, 1).End(3).Row - 1
        If dic.exists(arr(j, 1)) = False Then
            ActiveSheet.Rows(j + 1).Copy Sheets("固定資産管理台帳").Cells(100000, 1).End(3).Offset(1, 0)
        End If
    Next
    Exit Sub
a:  If ActiveSheet.Cells(100000, 4).End(3).Row > 1 Then
        ActiveSheet.Rows(2).Copy Sheets("固定資産管理台帳").Cells(100000, 1).End(3).Offset(1, 0)
    End If

End Sub
Sub 减少()
    Dim brr(), arr(), dic As Object, i As Long, j As Long, m As Long, a
    Set dic = CreateObject("scripting.dictionary")
   
    brr = Sheets("固定資産管理台帳").Range(Sheets("固定資産管理台帳").[d2], Sheets("固定資産管理台帳").Cells(100000, 4).End(3)).Value
    For i = 1 To Sheets("固定資産管理台帳").Cells(100000, 4).End(3).Row - 1
        dic(brr(i, 1)) = i + 1
    Next
    On Error GoTo a
    arr = ActiveSheet.Range([d2], Cells(1000000, 4).End(3)).Value
    For j = ActiveSheet.Cells(1000000, 1).End(3).Row - 1 To 1 Step -1
        If dic.exists(arr(j, 1)) = True Then
            Sheets("固定資産管理台帳").Rows(dic(arr(j, 1))) = ""
        End If
    Next
    For m = Sheets("固定資産管理台帳").Cells(1000000, 1).End(3).Row To 2 Step -1
        If Application.WorksheetFunction.CountA(Sheets("固定資産管理台帳").Rows(m)) = 0 Then
              Sheets("固定資産管理台帳").Rows(m).Delete
        End If
        
    Next
    Exit Sub
a:  If ActiveSheet.Cells(100000, 4).End(3).Row > 1 Then
       Sheets("固定資産管理台帳").Rows(dic(ActiveSheet.Cells(2, 4).Value)).Delete
    End If
End Sub

15162039800

谢谢分享,,,,,,,

15162039800

谢谢分享,,,,,,,,,,@