从表格中提取指定列内容到新表之中

新手594

昨天求助的提取内容已实现大部分需求，我一开始需求写的不够详细，哪位帮忙再完善一下。谢谢了。
目前还需补充的细节：
1.公司三取值信息存在多余，表头信息“'B公司2月份工资发放表”无需获取；人员和身份证号取值错列（公司三至公司五均存在错列，可能原因是原始是表中“人员”列不在第一列）
2.公司四和公司五中实发金额取值信息为空；
3.汇总表格可以不用取值（如果表格之中没有同时存在人员和实发金额两列信息的话，该表格不取值）。
附加说明：
1.判断每个表格之中如果同时存在人员和实发工资两列的话，则从人员单元格开始取值，并取对应人员的实发金额；
2.每个公司的表格之中的人员和实发金额列所在的位置不太一样，如果符合条件1的话需取到值；
3.部分公司的人员较多，人员和实发金额可能不连续，中间存在合并单元格或其他单元格信息（如公司四之中）。


用户fzxba帮忙写的代码，再次感谢。
他写的代码是这样的：

Sub test()

Dim Arr, Brr(1 To 100000, 1 To 4), i, j, n

Dim Sht As Worksheet

For Each Sht In Worksheets

   If Sht.Name <> "实发金额" Then

       Arr = Sht.UsedRange

       For i = 1 To UBound(Arr)

           n = n + 1

           For j = 1 To UBound(Arr, 2)

               

                Brr(n, 1) = Sht.Name

                Brr(n, 2) = Arr(i, 1)

                Brr(n, 3) = Arr(i, 2)

                Brr(n, 4) = Arr(i, UBound(Arr,2))

           Next

       Next

   End If

Next

n = 0

For i = 1 To UBound(Brr)

   If Brr(i, 3) <> "" And Brr(i, 3) <> "身份证号码"Then

       n = n + 1

       Brr(n, 1) = Brr(i, 1)

       Brr(n, 2) = Brr(i, 2)

       Brr(n, 3) = "'" & Brr(i, 3)

       Brr(n, 4) = Brr(i, 4)

   End If

Next

Range("a1").CurrentRegion.ClearContents

Range("a1").Resize(1, UBound(Brr,2)) = Array("表名", "人员", "身份证号", "实发金额")

Range("a2").Resize(n, UBound(Brr,2)) = Brr

End Sub

sxbjzjf110

修改了一 下，试试。。。

新手594

sxbjzjf110 发表于 2023-3-18 21:17
修改了一 下，试试。。。

非常感谢您的帮助，能否帮忙修改下判断条件（代码里面是用表格名字来处理的    If Sht.Name <> "实发金额" Or Sht.Name <> "汇总表格" Then），条件替换成表格里面没有同时存在人员和实发金额的时候可以不用取值。另外表格五中下面的单元格“审核人”如果和身份证号同一列也会被取过去，这个能否去掉。系统限制我今天再重新传附件了。