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

hhxq001

最近单位有工资表需要取数，网上找了一段代码，可以取数，但是如果目标表（扣项表中含空表头字段就不行），请高手给改一下，要求代码满足下面2个条件的：1、不提取人员类别为遗属的人的数据；2、即使目标表中间存在空字段也可以取数。自己小白搞不懂代码，求指点哦
提取相同字段数据到新表-求助1.zip (32.65 KB, 下载次数: 9)

2021-2-2 10:51 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-2-2 10:52

hhxq001 发表于 2021-2-2 16:43
新附件在这里，就是复制了你的代码，但是我增加了标题行

Sub demo()


    Dim d As Object

    Set d = CreateObject("scripting.dictionary")

    With ActiveSheet
        b = 12
        For i = 1 To b
            d(.Cells(2, i).Value) = i
        Next

        arr = Sheets("data").[a1].CurrentRegion
        h = UBound(arr) - 2
        ReDim brr(1 To h, 1 To b)

        k = 0
        For i = 4 To UBound(arr)
            If arr(i, 2) <> "遺屬" Then
                k = k + 1
                For j = 1 To UBound(arr, 2)
                    If d.exists(arr(2, j)) Then brr(k, d(arr(2, j))) = arr(i, j)
                Next
            End If
        Next

        clear
        .[a4].Resize(h, b) = brr

    End With

End Sub

Sub clear()
   ActiveSheet.UsedRange.Offset(3).clear
End Sub

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

cutecpu

hhxq001 发表于 2021-2-2 16:43
新附件在这里，就是复制了你的代码，但是我增加了标题行

Sub demo()


    Dim d As Object

    Set d = CreateObject("scripting.dictionary")

    With ActiveSheet
        b = 12
        For i = 1 To b
            d(.Cells(2, i).Value) = i
        Next

        arr = Sheets("data").[a1].CurrentRegion
        h = UBound(arr) - 2
        ReDim brr(1 To h, 1 To b)

        k = 0
        For i = 4 To UBound(arr)
            If arr(i, 2) <> "遺屬" Then
                k = k + 1
                For j = 1 To UBound(arr, 2)
                    If d.exists(arr(2, j)) Then brr(k, d(arr(2, j))) = arr(i, j)
                Next
            End If
        Next

        clear
        .[a4].Resize(h, b) = brr

    End With

End Sub

Sub clear()
   ActiveSheet.UsedRange.Offset(3).clear
End Sub

祝順心，南無阿彌陀佛！

cutecpu

Sub demo()

    Dim d As Object

    Set d = CreateObject("scripting.dictionary")

    With ActiveSheet
        l = 10
        For i = 1 To l
            d(.Cells(1, i).Value) = i
        Next

        arr = Sheets("data").[a1].CurrentRegion
        h = UBound(arr) - 2
        ReDim brr(1 To h, 1 To l)

        k = 0

        For i = 3 To UBound(arr)
            If arr(i, 2) <> "遺屬" Then
                k = k + 1
                For j = 1 To UBound(arr, 2)
                    If d.exists(arr(1, j)) Then brr(k, d(arr(1, j))) = arr(i, j)
                Next
            End If
        Next

        .[a1].CurrentRegion.Offset(1).Clear
        .[a3].Resize(h, l) = brr

    End With

End Sub

祝順心，南無阿彌陀佛！

hhxq001

cutecpu 发表于 2021-2-2 15:04
Sub demo()

    Dim d As Object

目前这2个表都是不带标题行的，我如果添加1-2行的标题行，就不能用了，怎么再改一下呢。
阿弥陀佛

cutecpu

hhxq001 发表于 2021-2-2 15:52
目前这2个表都是不带标题行的，我如果添加1-2行的标题行，就不能用了，怎么再改一下呢。
阿弥陀佛

您好，可以上傳不能用的附件嗎

hhxq001

cutecpu 发表于 2021-2-2 15:56
您好，可以上傳不能用的附件嗎

新附件在这里，就是复制了你的代码，但是我增加了标题行

根据关键字提取数据到新表-求助02.02 - 加标题行后出错.zip (32.89 KB, 下载次数: 5)

2021-2-2 16:42 上传

点击文件名下载附件

hhxq001

cutecpu 发表于 2021-2-2 18:56
Sub demo()

佛主也会熟练的操作vb代码，佩服啊佩服

hhxq001

cutecpu 发表于 2021-2-2 10:52
Sub demo()

小白不懂，能不能给注解一下代码呢

hhxq001

cutecpu 发表于 2021-2-2 10:52
Sub demo()

如果第一列不提取已有的序号，要求重新自动排序，怎么改呢

cutecpu

hhxq001 发表于 2021-2-2 21:05
如果第一列不提取已有的序号，要求重新自动排序，怎么改呢

您好，不是很懂這句的意思 →「不提取已有的序号，要求重新自动排序」