怎么把工作簿里用黄色底纹标记的单元格所在的行提取数据出来

zhouxing2008

求求老师帮帮忙啊，我在工作簿里用黄色底纹标记了一些单元格，希望把用黄色底纹标记的单元格所在的整行数据提取到一个新表中，怎么写代码啊，求求指点

liulang0808

楼主换个高级版本的office，可以根据颜色筛选的

zhouxing2008

liulang0808 发表于 2017-11-19 20:26
楼主换个高级版本的office，可以根据颜色筛选的

谢谢啊，我用的office2016，如果用vba怎么写代码啊，求指点下

zhouxing2008

liulang0808 发表于 2017-11-19 20:26
楼主换个高级版本的office，可以根据颜色筛选的

关键是一个工作簿里面的工作表太多了，就算筛选也只能一个表一个表的筛选吗？？怎么把多个工作表汇总一下啊，求指点

jiminyanyan

zhouxing2008 发表于 2017-11-19 20:31
关键是一个工作簿里面的工作表太多了，就算筛选也只能一个表一个表的筛选吗？？怎么把多个工作表汇总一下 ...

先用VBA 汇总成一个工作表,再按颜色筛选.....

zhouxing2008

jiminyanyan 发表于 2017-11-19 20:36
先用VBA 汇总成一个工作表,再按颜色筛选.....

真心感谢啊，办法真是灵活啊

zhouxing2008

jiminyanyan 发表于 2017-11-19 20:36
先用VBA 汇总成一个工作表,再按颜色筛选.....

还有，我们公司的excel文件都是单个单个的独立工作簿，并且是受保护的文件，我想把自己用黄色底纹标记的那行内容提取出来，只有先把公司的文件复制粘贴过来吗？？而且复制粘贴过来的文件也有问题，用vba就出错提示，怎么办

duquancai

Sub shishi()
    Dim sht As Worksheet, str$, c As Range, n&, r&
    str = "新表中"
    For Each sht In Sheets
        If sht.Name = str Then
            Application.DisplayAlerts = False
            sht.Delete
            Application.DisplayAlerts = True
        End If
    Next
    Application.ScreenUpdating = False
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = str
    Sheets(str).[a1:n1] = [{"隶属  关系","地区  代码","地区  名称","单位代码","单位名称","职位代码","职位名称","职位简介","职位类别","开考比例","招考人数","学　历","专　业","其　它"}]
    Application.FindFormat.Clear
    Application.FindFormat.Interior.Color = 65535
    For Each sht In Sheets
        If sht.Name <> str Then
            Set c = sht.Range("c:c").Find(what:="", LookIn:=xlValues, SearchFormat:=True)
            If Not c Is Nothing Then
                asd = c.Address
                Do
                    r = Sheets(str).Cells(Rows.Count, 1).End(3).Row + 1
                    Sheets(str).Range("a" & r & ":n" & r) = sht.Range("a" & c.Row & ":n" & c.Row).Value
                    Set c = sht.Range("c:c").Find(what:="", After:=c, SearchFormat:=True)
                Loop Until c.Address = asd
            End If
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "ok!"
End Sub

duquancai

zhouxing2008 发表于 2017-11-19 20:43
还有，我们公司的excel文件都是单个单个的独立工作簿，并且是受保护的文件，我想把自己用黄色底纹标记的 ...

附件，打开Excel文件，点击按钮》》》》》》

fxl447098457

1. Sub TEST()
   
2. Dim Sht As Worksheet, Rng As Range, LastCell As Range, i As Integer
   
3. Application.ScreenUpdating = False
   
4. If Not IsEmpty(Sheets("汇总").UsedRange) Then Sheets("汇总").UsedRange.Clear
   
5. For Each Sht In Worksheets
   
6.     With Sht
   
7.       If .Name <> "汇总" Then
   
8.         i = i + 1
   
9.         If .AutoFilterMode = False Then .[A5].AutoFilter
   
10.         .AutoFilter.Range.AutoFilter Field:=3, Criteria1:=RGB(255, _
    
11.         255, 0), Operator:=xlFilterCellColor
    
12.         Set Rng = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    
13.         If Not Rng Is Nothing Then
    
14.             If i = 1 Then
    
15.                 Set LastCell = Sheets("汇总").[A1]
    
16.          Else
    
17.             Set LastCell = Sheets("汇总").Cells(Rows.Count, 1).End(3).Offset(1)
    
18.         End If
    
19.           Rng.Copy LastCell
    
20.         If i > 1 Then LastCell.EntireRow.Delete
    
21.         End If
    
22.         .ShowAllData
    
23.         .[A5].AutoFilter
    
24.      End If
    
25.     End With
    
26. Next
    
27. Application.ScreenUpdating = True
    
28. Set Sht = Nothing
    
29. Set Rng = Nothing
    
30. Set LastCell = Nothing
    
31. End Sub

复制代码