把符合条件的多个工作表数据复制到一个工作表中

全党

压缩包中有说明

tiger1976

Sub lll()

    Dim sht As Worksheet
    Dim i As Integer
    Dim k As Integer
   
    Range("a4:f497").ClearContents
    Range("r4:w497").ClearContents
    For Each sht In Sheets
        If sht.Name <> "汇总" Then
            i = sht.Cells(Rows.Count, 5).End(xlUp).Row
            For k = 4 To i
                If sht.Cells(k, 5) = "在职" Then
                    h = h + 1
                    Sheets("汇总").Cells(3 + h, 1) = h
                    Sheets("汇总").Cells(3 + h, 2) = sht.Cells(k, 2)
                    Sheets("汇总").Cells(3 + h, 3) = sht.Cells(k, 3)
                    Sheets("汇总").Cells(3 + h, 4) = sht.Cells(k, 4)
                    Sheets("汇总").Cells(3 + h, 5) = sht.Cells(k, 5)
                    Sheets("汇总").Cells(3 + h, 6) = sht.Cells(k, 6)
                    Sheets("汇总").Cells(3 + h, "r") = sht.Cells(k, "r")
                    Sheets("汇总").Cells(3 + h, "s") = sht.Cells(k, "s")
                    Sheets("汇总").Cells(3 + h, "t") = sht.Cells(k, "t")
                    Sheets("汇总").Cells(3 + h, "u") = sht.Cells(k, "u")
                    Sheets("汇总").Cells(3 + h, "v") = sht.Cells(k, "v")
                    Sheets("汇总").Cells(3 + h, "w") = sht.Cells(k, "w")
                    Sheets("汇总").Cells(3 + h, "x") = sht.Cells(k, "x")
                End If
            Next
        End If
    Next


End Sub

tiger1976

Sub lll()

    Dim sht As Worksheet
    Dim i As Integer
    Dim k As Integer
   
    Range("a4:f497").ClearContents
    Range("r4:w497").ClearContents
    For Each sht In Sheets
        If sht.Name <> "汇总" Then
            i = sht.Cells(Rows.Count, 5).End(xlUp).Row
            For k = 4 To i
                If sht.Cells(k, 5) = "在职" Then
                    h = h + 1
                    Sheets("汇总").Cells(3 + h, 1) = h
                    Sheets("汇总").Cells(3 + h, 2) = sht.Cells(k, 2)
                    Sheets("汇总").Cells(3 + h, 3) = sht.Cells(k, 3)
                    Sheets("汇总").Cells(3 + h, 4) = sht.Cells(k, 4)
                    Sheets("汇总").Cells(3 + h, 5) = sht.Cells(k, 5)
                    Sheets("汇总").Cells(3 + h, 6) = sht.Cells(k, 6)
                    Sheets("汇总").Cells(3 + h, "r") = sht.Cells(k, "r")
                    Sheets("汇总").Cells(3 + h, "s") = sht.Cells(k, "s")
                    Sheets("汇总").Cells(3 + h, "t") = sht.Cells(k, "t")
                    Sheets("汇总").Cells(3 + h, "u") = sht.Cells(k, "u")
                    Sheets("汇总").Cells(3 + h, "v") = sht.Cells(k, "v")
                    Sheets("汇总").Cells(3 + h, "w") = sht.Cells(k, "w")
                    Sheets("汇总").Cells(3 + h, "x") = sht.Cells(k, "x")
                End If
            Next
        End If
    Next


End Sub

全党

tiger1976 发表于 2022-11-27 23:16
Sub lll()

    Dim sht As Worksheet

牛！！完美。

Hontyu

            参与一下

Hontyu

.............

ykcbf1100

用数组提升一下速度。

全党

Hontyu 发表于 2022-11-28 11:49
.............

统计到一个表后，如果再把姓名和身份证列号码同时重复的行删除，只保留一行呢。

全党

ykcbf1100 发表于 2022-11-28 11:55
用数组提升一下速度。

谢谢，我这里运行时，显示下界越标。

ykcbf1100

全党 发表于 2022-11-28 12:34
谢谢，我这里运行时，显示下界越标。

有容错语句怎么会有错误提示？