红色代码出错

djyang

Sub lqxs()
For Each a In Sheets
a.Unprotect Password:="05773303"
Dim Arr, i&, Sht As Worksheet
Dim d, k
Set d = CreateObject("Scripting.Dictionary")
For Each Sht In Sheets
    d(Sht.Name) = ""
Next
k = d.keys
Arr = Sheet3.[a1].CurrentRegion
For i = 4 To UBound(Arr)
    If i = 4 Then Set Sht = Sheets(Arr(i, 1))
    If Not d.exists(Arr(i, 1)) Then
        Sht.Copy after:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = Arr(i, 1)
            .[b2] = Arr(i, 2): .[b3] = Arr(i, 3)
            .[e2] = Arr(i, 1): .[e3] = Arr(i, 4)
            .[f3] = Arr(i, 6): .[g3] = Arr(i, 7): .[h3] = Arr(i, 8)
            .[j3] = ""
            Union(.[a5:a1000], .[c5:c1000], .[g5:h1000], .[j5:k1000]).ClearContents
        End With
    End If
Next
For Each a In Sheets
a.Protect Password:="05773303"
Next
End Sub



Sub lqxs()
For Each a In Sheets
a.Unprotect Password:="05773303"
Dim Arr, i&, Sht As Worksheet
Dim d, k
Next
For Each a In Sheets
a.Protect Password:="05773303"
Next
上面的红色代码是我加上的，老师帮忙看一下 17-5加密.zip (49.98 KB, 下载次数: 5)

2017-6-23 20:54 上传

点击文件名下载附件

djyang

Sub lqxs()

Dim Arr, i&, Sht As Worksheet
Dim d, k
Set d = CreateObject("Scripting.Dictionary")
For Each Sht In Sheets
    d(Sht.Name) = ""
Next
k = d.keys
Arr = Sheet3.[a1].CurrentRegion
For i = 4 To UBound(Arr)
    If i = 4 Then Set Sht = Sheets(Arr(i, 1))
    If Not d.exists(Arr(i, 1)) Then
        Sht.Copy after:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = Arr(i, 1)
            .[b2] = Arr(i, 2): .[b3] = Arr(i, 3)
            .[e2] = Arr(i, 1): .[e3] = Arr(i, 4)
            .[f3] = Arr(i, 6): .[g3] = Arr(i, 7): .[h3] = Arr(i, 8)
            .[j3] = ""
            Union(.[a5:a1000], .[c5:c1000], .[g5:h1000], .[j5:k1000]).ClearContents
        End With
    End If
Next
For Each a In Sheets
a.Protect Password:="05773303"
Next
End Sub
以上代码可以运行 17-5加密.zip (49.98 KB, 下载次数: 7)

2017-6-23 20:53 上传

点击文件名下载附件

只想两个代码合并，请老师修改。