用VBA代码提取数据报错不知什么原因，请指点。

wxffgb

我用VBA代码提取数据时，总报错，不d知道错在哪里，请指点，详见附件。
第一段代码，绿色标识代码报错
Sub 利用数组提取不重复值()
Z = Sheets("申请明细").Cells(Rows.Count, 1)
Dim arr1(1 To 10000)
Set lastcell = Sheets("申请明细").Cells(Rows.Count, 1).End(xlUp) '查找最后B列最后一个非空单元格
     arr = Sheets("申请明细").Range([a2], lastcell)    '将a列的姓名数据赋值给变量arr形成一个数组
For i = 1 To lastcell.Row - 1   '循环a列单元格个数的次数
    For j = 1 To UBound(arr1)   '找到arr1数组的最大小标，形成循环
        x = arr(i, 1): y = arr1(j) '辅助代码
        If arr(i, 1) = arr1(j) Then
            GoTo 100    'arr数组元素与arr1元素循环对比，如果相等，则跳出内层循环
        End If
    Next j
        k = k + 1   '做个计数器，计算相等重复的元素人数
        arr1(k) = arr(i, 1)  '如果循环完后都没有相等的，则将arr1循环的元素赋值给arr1数组
100:
Next i
Sheet1("明细记录").[a3].Resize(k) = Application.Transpose(arr1)   '循环结束后将arr1的结果赋值给单元格区域
End Sub

第二段代码，绿色标识报错
Sub 计划行号查询()
Set d = CreateObject("scripting.dictionary")
Set Z = CreateObject("scripting.dictionary")
Set x = CreateObject("scripting.dictionary")
For Each sh In Sheets
    c = sh.Name
    If sh.Name = "申请明细" Then
        arr = sh.Range("a2:a" & sh.Cells(Rows.Count, 1).End(xlUp).Row)
      
        For Each Rng In arr
           
            d(Rng) = ""
        Next
     End If
      Sheets("明细记录").Cells [a3].Resize(d.Count) = Application.Transpose(d.keys)
'依据计划行号提取相关数据到明细表
       With Sheets("申请明细")
            arr = .Range("a2:ax" & .Cells(Rows.Count, 1).End(xlUp).Row)
       End With
       For i = 1 To UBound(arr)
           Z(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 20), arr(i, 40))
                      j = Z(arr(i, 1))
       Next
       For Each Rng In Sheets("明细记录").Range("a3:a" & Cells(Rows.Count, 1).End(xlUp).Row)
       Rng.Offset(0, 1).Resize(1, 4) = Z(Rng.Value)
       Next
'依据计划行号提取申请中心
If sh.Name = "基础信息" Then
    arr = sh.Range("a3:c" & sh.Cells(Rows.Count, 1).End(xlUp).Row)
For i = 1 To UBound(arr)
    x(arr(i, 1)) = Array(arr(i, 3))
    j = x(arr(i, 1))
Next
    End If
For Each Rng In Range("e3:e" & Cells(Rows.Count, 1).End(xlUp).Row)
   Rng.Offset(0, 1).Resize(1, 1) = x(Rng.Value)
Next
Next
End Sub

第三段代码，提取不出数据，不知道错在哪里？
Sub P3计划行号查询()
Set x = CreateObject("scripting.dictionary")
For Each sh In Sheets
    c = sh.Name
    If sh.Name <> "领用明细" Then GoTo 100
    arr = sh.Range("a2:ar" & sh.Cells(Rows.Count, 1).End(xlUp).Row)
For i = 1 To UBound(arr)
    x(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4))
    j = x(arr(i, 1))
Next
    'Else: GoTo 100
   
   
For Each Rng In Sheets("明细记录").Range("a3:a" & Cells(Rows.Count, 1).End(xlUp).Row)
   Rng.Offset(0, 6).Resize(1, 3) = x(Rng.Value)
Next
'100:
Next
End Sub

abc123281

arr = Sheets("申请明细").Range([a2], lastcell)
cells不支持多单元格区域  改为range

abc123281

Sheets("明细记录").[a3].Resize(k) = Application.Transpose(arr1)

wxffgb

还是不行呀

刀羊

1.       arr = Sheets("申请明细").Range(Sheets("申请明细").range("A2"), lastcell)   

2.       LZ标记行之前 IF  ......  end if 已做过了，如果不符合，则d.count＝0啊，而且，d(rng)是要将一个cell对象放到字典里吗？