[已解决]怎么才能保证有空字段也能取数

hhxq001

cutecpu 发表于 2021-2-18 16:18
藍色：orr = Sheets(month & "月其他收入").[a1].CurrentRegion
紅色：orr = Sheets(month & "月其他 ...

超版，现在出现一个情况，改了这句后orr = Sheets(month & "月其他收入").UsedRange，在win7+office的电脑上正常，文件复制到win10+office2019的电脑上，点击提取按钮，提示错误：运行时出错 “9”  下标越界并且跳转到sheet1表


怎么回事呢

cutecpu

hhxq001 发表于 2021-2-27 10:40
超版，现在出现一个情况，改了这句后orr = Sheets(month & "月其他收入").UsedRange，在win7+office的电 ...

哇~~這樣呀，我沒有 win10 + office2019 的環境可以測試耶！
看要不要發新帖，請版上其他高手幫忙一下！

hhxq001

cutecpu 发表于 2021-2-27 15:56
哇~~這樣呀，我沒有 win10 + office2019 的環境可以測試耶！
看要不要發新帖，請版上其他高手幫忙一下！ ...

网上搜半天没找到相同遭遇者，没有别的办法，在win10电脑 上安装了office2010解决了。
再请教超版，这个工作簿随着工作表的增加（增到共12个月每月3种表），每次点击每个月的提取按钮只能提取当月的数据，很麻烦。能不能通过代码实现，不管点击哪个月汇总表里的“提取按钮”都可以一次性完成所有月份的提取过程，节约操作时间，请赐教。


一次性提取问题0227.part1.rar (1 MB, 下载次数: 2)

2021-2-27 22:16 上传

点击文件名下载附件 一次性提取问题0227.part2.rar (89.46 KB, 下载次数: 2)

2021-2-27 22:16 上传

点击文件名下载附件

cutecpu

hhxq001 发表于 2021-2-27 22:16
网上搜半天没找到相同遭遇者，没有别的办法，在win10电脑 上安装了office2010解决了。
再请教超版，这个 ...

藍色為新增部份

Sub demo()

   Dim month
   
   For month = 1 To 12
   
   If Not WorksheetExists(month & "月汇总") Then Exit For
   
   Sheets(month & "月汇总").Select

   clear

   Set d = CreateObject("scripting.dictionary")

   orr = Sheets(month & "月其他收入").UsedRange

   For I = 6 To UBound(orr)
      Key = orr(I, 5)
      If d.exists(Key) Then
         prev = d(Key)
         For k = 9 To 18
            orr(I, k) = orr(I, k) + orr(prev, k)
         Next
      End If
      d(Key) = I
   Next

   arr = Sheets(month & "月工资").[a1].CurrentRegion

   ReDim brr(1 To UBound(arr), 1 To 3)
   ReDim crr(1 To UBound(arr), 1 To 5)
   ReDim drr(1 To UBound(arr), 1 To 10)

   For I = 5 To UBound(arr)
      If arr(I, 1) = "" Then Exit For
      If arr(I, 4) = "遗属" Then GoTo CONTINUE
      r = r + 1
      Key = arr(I, 2)
      brr(r, 1) = Key
      brr(r, 2) = arr(I, 3)
      brr(r, 3) = arr(I, 5)
      crr(r, 1) = arr(I, 8)
      crr(r, 2) = arr(I, 9)
      crr(r, 3) = arr(I, 6)
      crr(r, 4) = arr(I, 7)
      crr(r, 5) = arr(I, 10)

      drr(r, 1) = "": drr(r, 2) = "": drr(r, 3) = "": drr(r, 4) = "": drr(r, 5) = "": drr(r, 6) = "": drr(r, 7) = "": drr(r, 8) = "": drr(r, 9) = "": drr(r, 10) = ""
      If d.exists(Key) Then
         drr(r, 1) = orr(d(Key), 9)
         drr(r, 2) = orr(d(Key), 10)
         drr(r, 3) = orr(d(Key), 11)
         drr(r, 4) = orr(d(Key), 12)
         drr(r, 5) = orr(d(Key), 13)
         drr(r, 6) = orr(d(Key), 14)
         drr(r, 7) = orr(d(Key), 15)
         drr(r, 8) = orr(d(Key), 16)
         drr(r, 9) = orr(d(Key), 17)
         drr(r, 10) = orr(d(Key), 18)

         d.Remove Key
      End If

CONTINUE:
   Next

   [e7].Resize(r, 3) = brr
   [w7].Resize(r, 5) = crr
   [h7].Resize(r, 10) = drr

   ReDim Err(1 To d.Count(), 1 To 3)
   ReDim frr(1 To d.Count(), 1 To 10)

   For Each Key In d.keys()
      rr = rr + 1
      Err(rr, 1) = orr(d(Key), 5)
      Err(rr, 2) = orr(d(Key), 4)

      frr(rr, 1) = orr(d(Key), 9)
      frr(rr, 2) = orr(d(Key), 10)
      frr(rr, 3) = orr(d(Key), 11)
      frr(rr, 4) = orr(d(Key), 12)
      frr(rr, 5) = orr(d(Key), 13)
      frr(rr, 6) = orr(d(Key), 14)
      frr(rr, 7) = orr(d(Key), 15)
      frr(rr, 8) = orr(d(Key), 16)
   Next

   Range("e" & 7 + r).Resize(rr, 3) = Err
   Range("h" & 7 + r).Resize(rr, 10) = frr

   Next

End Sub

Sub clear()

   lastRow = Range("e65536").End(xlUp).Row
   If lastRow < 7 Then lastRow = 7
   Range("e7:q" & lastRow & ",w7:aa" & lastRow).ClearContents

End Sub

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function


祝順心，南無阿彌陀佛！

hhxq001

cutecpu 发表于 2021-2-27 23:43
藍色為新增部份

Sub demo()

后面几句蓝色代码放到哪里，我不懂，所以全复制粘贴进去了，运行时出错，提示下标越界，停在 Err(rr, 1) = orr(d(Key), 5)      Err(rr, 2) = orr(d(Key), 4)

一次性提取问题0227.part1.rar (1 MB, 下载次数: 3)

2021-2-28 10:55 上传

点击文件名下载附件 一次性提取问题0227.part2.rar (102.24 KB, 下载次数: 3)

2021-2-28 10:55 上传

点击文件名下载附件

cutecpu

hhxq001 发表于 2021-2-28 10:35
后面几句蓝色代码放到哪里，我不懂，所以全复制粘贴进去了，运行时出错，提示下标越界，停在 Err(rr, 1)  ...

紅色新增部份

Sub demo()

   Dim month
   
   For month = 1 To 12
   
   If Not WorksheetExists(month & "月汇总") Then Exit For
   
   Sheets(month & "月汇总").Select

   clear

   Set d = CreateObject("scripting.dictionary")

   orr = Sheets(month & "月其他收入").UsedRange

   For I = 6 To UBound(orr)
      Key = orr(I, 5)
      If d.exists(Key) Then
         prev = d(Key)
         For k = 9 To 18
            orr(I, k) = orr(I, k) + orr(prev, k)
         Next
      End If
      d(Key) = I
   Next

   arr = Sheets(month & "月工资").[a1].CurrentRegion

   ReDim brr(1 To UBound(arr), 1 To 3)
   ReDim crr(1 To UBound(arr), 1 To 5)
   ReDim drr(1 To UBound(arr), 1 To 10)

   r = 0
   For I = 5 To UBound(arr)
      If arr(I, 1) = "" Then Exit For
      If arr(I, 4) = "遗属" Then GoTo CONTINUE
      r = r + 1
      Key = arr(I, 2)
      brr(r, 1) = Key
      brr(r, 2) = arr(I, 3)
      brr(r, 3) = arr(I, 5)
      crr(r, 1) = arr(I, 8)
      crr(r, 2) = arr(I, 9)
      crr(r, 3) = arr(I, 6)
      crr(r, 4) = arr(I, 7)
      crr(r, 5) = arr(I, 10)

      drr(r, 1) = "": drr(r, 2) = "": drr(r, 3) = "": drr(r, 4) = "": drr(r, 5) = "": drr(r, 6) = "": drr(r, 7) = "": drr(r, 8) = "": drr(r, 9) = "": drr(r, 10) = ""
      If d.exists(Key) Then
         drr(r, 1) = orr(d(Key), 9)
         drr(r, 2) = orr(d(Key), 10)
         drr(r, 3) = orr(d(Key), 11)
         drr(r, 4) = orr(d(Key), 12)
         drr(r, 5) = orr(d(Key), 13)
         drr(r, 6) = orr(d(Key), 14)
         drr(r, 7) = orr(d(Key), 15)
         drr(r, 8) = orr(d(Key), 16)
         drr(r, 9) = orr(d(Key), 17)
         drr(r, 10) = orr(d(Key), 18)

         d.Remove Key
      End If

CONTINUE:
   Next

   [e7].Resize(r, 3) = brr
   [w7].Resize(r, 5) = crr
   [h7].Resize(r, 10) = drr

   ReDim Err(1 To d.Count(), 1 To 3)
   ReDim frr(1 To d.Count(), 1 To 10)

   rr = 0
   For Each Key In d.keys()
      rr = rr + 1
      Err(rr, 1) = orr(d(Key), 5)
      Err(rr, 2) = orr(d(Key), 4)

      frr(rr, 1) = orr(d(Key), 9)
      frr(rr, 2) = orr(d(Key), 10)
      frr(rr, 3) = orr(d(Key), 11)
      frr(rr, 4) = orr(d(Key), 12)
      frr(rr, 5) = orr(d(Key), 13)
      frr(rr, 6) = orr(d(Key), 14)
      frr(rr, 7) = orr(d(Key), 15)
      frr(rr, 8) = orr(d(Key), 16)
   Next

   Range("e" & 7 + r).Resize(rr, 3) = Err
   Range("h" & 7 + r).Resize(rr, 10) = frr

   Next

End Sub

Sub clear()

   lastRow = Range("e65536").End(xlUp).Row
   If lastRow < 7 Then lastRow = 7
   Range("e7:q" & lastRow & ",w7:aa" & lastRow).ClearContents

End Sub

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function


祝順心，南無阿彌陀佛！

hhxq001

cutecpu 发表于 2021-2-28 14:48
紅色新增部份

Sub demo()

老师真厉害，一出手就解决了困惑。再讨教：1、我如果在3月汇总表里点击的提取按钮，完成后要求还是停留在3月汇总表，修改哪句代码呢。目前的情况是不管在哪个月点击提取按钮，最后都返回到6月汇总表。2、如果其他收入表的身份证和姓名列为空，而收入项目不小心有数据，结果提取的时候就把数据也提取了，能不能做个判断，如果身份证列单元格没有信息就不提取？

cutecpu

hhxq001 发表于 2021-2-28 15:38
老师真厉害，一出手就解决了困惑。再讨教：我如果在3月汇总表里点击的提取按钮，完成后要求还是停留在3月 ...

橘色新增部份

Sub demo()

   shName = ActiveSheet.Name
   Dim month
   
   For month = 1 To 12
   
   If Not WorksheetExists(month & "月汇总") Then Exit For
   
   Sheets(month & "月汇总").Select

   clear

   Set d = CreateObject("scripting.dictionary")

   orr = Sheets(month & "月其他收入").UsedRange

   For I = 6 To UBound(orr)
      Key = orr(I, 5)
      If d.exists(Key) Then
         prev = d(Key)
         For k = 9 To 18
            orr(I, k) = orr(I, k) + orr(prev, k)
         Next
      End If
      d(Key) = I
   Next

   arr = Sheets(month & "月工资").[a1].CurrentRegion

   ReDim brr(1 To UBound(arr), 1 To 3)
   ReDim crr(1 To UBound(arr), 1 To 5)
   ReDim drr(1 To UBound(arr), 1 To 10)

   r = 0
   For I = 5 To UBound(arr)
      If arr(I, 1) = "" Then Exit For
      If arr(I, 4) = "遗属" Then GoTo CONTINUE
      r = r + 1
      Key = arr(I, 2)
      brr(r, 1) = Key
      brr(r, 2) = arr(I, 3)
      brr(r, 3) = arr(I, 5)
      crr(r, 1) = arr(I, 8)
      crr(r, 2) = arr(I, 9)
      crr(r, 3) = arr(I, 6)
      crr(r, 4) = arr(I, 7)
      crr(r, 5) = arr(I, 10)

      drr(r, 1) = "": drr(r, 2) = "": drr(r, 3) = "": drr(r, 4) = "": drr(r, 5) = "": drr(r, 6) = "": drr(r, 7) = "": drr(r, 8) = "": drr(r, 9) = "": drr(r, 10) = ""
      If d.exists(Key) Then
         drr(r, 1) = orr(d(Key), 9)
         drr(r, 2) = orr(d(Key), 10)
         drr(r, 3) = orr(d(Key), 11)
         drr(r, 4) = orr(d(Key), 12)
         drr(r, 5) = orr(d(Key), 13)
         drr(r, 6) = orr(d(Key), 14)
         drr(r, 7) = orr(d(Key), 15)
         drr(r, 8) = orr(d(Key), 16)
         drr(r, 9) = orr(d(Key), 17)
         drr(r, 10) = orr(d(Key), 18)

         d.Remove Key
      End If

CONTINUE:
   Next

   [e7].Resize(r, 3) = brr
   [w7].Resize(r, 5) = crr
   [h7].Resize(r, 10) = drr

   ReDim Err(1 To d.Count(), 1 To 3)
   ReDim frr(1 To d.Count(), 1 To 10)

   rr = 0
   For Each Key In d.keys()
      rr = rr + 1
      Err(rr, 1) = orr(d(Key), 5)
      Err(rr, 2) = orr(d(Key), 4)

      frr(rr, 1) = orr(d(Key), 9)
      frr(rr, 2) = orr(d(Key), 10)
      frr(rr, 3) = orr(d(Key), 11)
      frr(rr, 4) = orr(d(Key), 12)
      frr(rr, 5) = orr(d(Key), 13)
      frr(rr, 6) = orr(d(Key), 14)
      frr(rr, 7) = orr(d(Key), 15)
      frr(rr, 8) = orr(d(Key), 16)
   Next

   Range("e" & 7 + r).Resize(rr, 3) = Err
   Range("h" & 7 + r).Resize(rr, 10) = frr

   Next

   Sheets(shName).Select

End Sub

Sub clear()

   lastRow = Range("e65536").End(xlUp).Row
   If lastRow < 7 Then lastRow = 7
   Range("e7:q" & lastRow & ",w7:aa" & lastRow).ClearContents

End Sub

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

hhxq001

cutecpu 发表于 2021-2-28 15:49
橘色新增部份

Sub demo()

老师出手好快啊，我还在琢磨、困惑中，就OK了

请再接招，如果其他收入表的身份证和姓名列为空（暂时无数据），而收入项目不小心填了数据，结果提取的时候就把数据也提取了，能不能做个判断，如果身份证列单元格没有信息就不提取？只提取有身份证信息的？

cutecpu

hhxq001 发表于 2021-2-28 15:55
老师出手好快啊，我还在琢磨、困惑中，就OK了

请再接招，如果其他收入表的身份证和姓名列为空（暂时无 ...

您好，這個讓您 「琢磨」一下喔！