用宏语言实现定位并复制 [

echotiny

就是要把表格名称为含有“8” 的，，就是要8月份的，不用7月份
定位其中为“优秀”的员工  并把那一列复制到第一个表，可以不用管表头那些什么部门
因为后面各个部门的表格存在长度不一，还有多车间


要求效果大概是这样子的
人事部8  黄八..................    优秀
生产部8  程咬金............................优秀
...................................


不一定所有表格都有优秀员工
求整一行复制 每行长短不一，每列名字也不在同一列上

echotiny

我把名字都定位在第一列了   就是写代码的时候可不可以定位到“优秀”  并且复制这一整行，并且如何跳过第一个财务部没有“优秀” 的单元格

蓝桥玄霜

每列名字也不在同一列上? 表格数据一定要规范，不能乱七八糟的。

echotiny

蓝桥玄霜 发表于 2019-9-30 13:19
每列名字也不在同一列上? 表格数据一定要规范，不能乱七八糟的。

那如果前面条件里面每列名字都对其了  其它条件不变   改怎么操作呢 感谢

liulang0808

楼主的数据不规范，看绿使用find定位“优秀”的位置吧
具体可以论坛查案例的

echotiny

应该是可以加个条件判断  if  找不到“优秀” 便去下一个表格

youzhenhappy

Sub 提取优秀员工()
    Dim Dcells
    Dim sht As Worksheet
    Dim i As Long, j As Long, k As Long, n As Long
    n = 2
   
    For Each sht In Worksheets '遍历工作表
        If sht.Name <> "优秀员工" Then
            Dcells = sht.UsedRange
            If IsEmpty(Dcells) Then
               GoTo LFor
            End If
            
            For i = LBound(Dcells) To UBound(Dcells)
                For j = LBound(Dcells, 2) To UBound(Dcells, 2)
                    If Dcells(i, j) = "优秀" Then
                        
                        For k = j To 1 Step -1
                            ActiveWorkbook.Worksheets("优秀员工").Cells(n, k) = Dcells(i, k)
                        Next
                        n = n + 1
                    End If
                Next j
            Next i
            
            
            
        End If
LFor:
    Next
   
End Sub

Yalishanda30

echotiny 发表于 2019-10-6 10:16
应该是可以加个条件判断  if  找不到“优秀” 便去下一个表格

附件供参考

shi353

Sub tt33()
Dim A()
Sheet1.[A2:C65000].ClearContents
For i = 1 To Sheets.Count
    N = Sheets(i).Name
    If Sheets(i).Name <> "优秀员工" Then
       Set rng = Sheets(i).Cells.Find("优秀")
       If Not rng Is Nothing Then
            FD = rng.Address
                m = m + 1
                ReDim Preserve A(1 To 3, 1 To m)
                A(1, m) = Sheets(i).Name
                A(2, m) = rng.End(1)
                A(3, m) = "优秀"
            '-----------------------
            Do
                Set rng = Sheets(i).Cells.FindNext(rng)
                LD = rng.Address
                If FD <> LD Then
                    m = m + 1
                    ReDim Preserve A(1 To 3, 1 To m)
                    A(1, m) = Sheets(i).Name
                    A(2, m) = rng.End(1)
                    A(3, m) = "优秀"
                End If
            Loop Until FD = LD
       End If
    End If
Next
'---------------------------------
A = Application.Transpose(A)
Sheet1.[A2].Resize(UBound(A), UBound(A, 2)) = A
End Sub

echotiny

蟹蟹蟹蟹