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

hhxq001

cutecpu 发表于 2021-2-28 16:17
您好，這個讓您 「琢磨」一下喔！

小白一枚，只能把版主的秘籍看明白半截。还是指点迷津吧

cutecpu

hhxq001 发表于 2021-2-28 17:44
小白一枚，只能把版主的秘籍看明白半截。还是指点迷津吧

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


針對紅色部份，要不要截個圖說明一下

hhxq001

cutecpu 发表于 2021-2-28 17:56
如果其他收入表的身份证和姓名列为空（暂时无数据），而收入项目不小心填了数据，结果提取的时候就把数据 ...

上图为1月其他收入表的情况，下图为汇总表提取后的情况。



没有身份证信息的行不提取，能实现吗？
一次性提取问题0227.part2.rar (105.41 KB, 下载次数: 2)

2021-2-28 21:23 上传

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

2021-2-28 21:23 上传

点击文件名下载附件

cutecpu

hhxq001 发表于 2021-2-28 21:20
上图为1月其他收入表的情况，下图为汇总表提取后的情况。

粉紅色部份新增

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
      If Key <> "" Then 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

   If d.Count Then
      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

   end if

   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 21:51
粉紅色部份新增

Sub demo()

谢谢相助。。。

hhxq001

cutecpu 发表于 2021-2-28 21:51
粉紅色部份新增

Sub demo()

老师再次打扰了，又发现一个问题：如果1月工资表为空白，再次出现错误提示，见下图，希望可以得到你的帮助。

cutecpu

hhxq001 发表于 2021-3-9 11:33
老师再次打扰了，又发现一个问题：如果1月工资表为空白，再次出现错误提示，见下图，希望可以得到你的帮 ...

您好，上傳一下附件喔。

hhxq001

cutecpu 发表于 2021-3-9 12:35
您好，上傳一下附件喔。

一次性提取问题0309.part1.rar (500 KB, 下载次数: 2)

2021-3-9 14:49 上传

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

2021-3-9 14:49 上传

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

2021-3-9 14:49 上传

点击文件名下载附件

cutecpu

hhxq001 发表于 2021-3-9 14:49

橘色部份新增

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
      If Key <> "" Then 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

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

   If d.Count Then
      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

   end if

   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-3-9 15:30
橘色部份新增

Sub demo()

谢谢这么快答复。。。