注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

零售创新,创新那些事儿,SPSS,VBA

零售创新

 
 
 

日志

 
 
关于我

新浪微博,零售创新 研究经理,数据分析师 希望和市场研究和零售业的同事共同进步! 本博客发表的都是免费或试用的资料,如果有版权问题请发邮件wangli12a@163.com联系删除。 spss excel vba blog

网易考拉推荐

Excel vba 提取与选中单元格格颜色相同的单元格  

2012-04-10 09:02:30|  分类: VB和VBA知识 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

Excel vba 提取与选中单元格格颜色相同的单元格


按 Alt + F11 ,进入代码编辑页面,将下面的代码贴入,鼠标点在第一段代码中间位置,按 F5 运行代码

-------------------------------

Public Sub 提取与选中单元格格颜色相同的单元格()

'在当前表内提取与当前相同的所有单元格,按照原位置复制到新建的新表内

'无论单元格的背景色是手动设置的,还是条件格式计算后生成的,本程序都能处理

Dim ir As Integer, ic As Integer
Dim ise As Integer
Dim inm As String
Dim isht1 As Worksheet, isht2 As Worksheet
Dim c As Range

On Error GoTo ierror

Set isht1 = ActiveSheet
ir = isht1.UsedRange.Rows.Count
ic = isht1.UsedRange.Columns.Count

If Selection.Cells.Count > 1 Then
MsgBox "当前选择了多个单元格!" & vbCrLf & vbCrLf & "请选择 1 个有背景色的单元格"
Exit Sub
Else
ise = ConditionalColor(ActiveCell, "Interior")
If ise < 1 Then
    MsgBox "当前单元格无背景色!" & vbCrLf & vbCrLf & "请选择 1 个有背景色的单元格"
    Exit Sub
End If
End If

Set isht2 = Worksheets.Add
isht1.Activate
MsgBox "新建 " & isht2.Name & " 表格,正准备提取数据到该表中……"

For Each c In isht1.Range("a1").Resize(ir, ic)
If ise = ConditionalColor(c, "Interior") Then c.Copy isht2.Cells(c.Row, c.Column)
Next
Application.CutCopyMode = False

MsgBox "已完成提取,请验收!"


Exit Sub
ierror: MsgBox "Error Number : " & Err.Number
End Sub


Function ConditionalColor(rg As Range, FormatType As String) As Long

'Returns the color index (either font or interior) of the first cell in range rg. If no _
conditional format conditions apply, then returns the regular color of the cell. _
FormatType is either "Font" or "Interior"

Dim cel As Range
Dim tmp As Variant
Dim boo As Boolean
Dim frmla As String, frmlaR1C1 As String, frmlaA1 As String
Dim i As Long

'Application.Volatile
'This statement required if Conditional Formatting for rg is determined by the value of other cells

Set cel = rg.Cells(1, 1)
Select Case Left(LCase(FormatType), 1)
   Case "f" 'Font color
     ConditionalColor = cel.Font.ColorIndex
   Case Else 'Interior or highlight color
     ConditionalColor = cel.Interior.ColorIndex
End Select

If cel.FormatConditions.Count > 0 Then
'On Error Resume Next
   With cel.FormatConditions
  
     For i = 1 To .Count    'Loop through the three possible format conditions for each cell
       frmla = .Item(i).Formula1
      
       If Left(frmla, 1) = "=" Then    'If "Formula Is", then evaluate if it is True
         'Conditional Formatting is interpreted relative to the active cell. _
          This cause the wrong results if the formula isn't restated relative to the cell containing the _
          Conditional Formatting--hence the workaround using ConvertFormula twice in a row. _
          If the function were not called using a worksheet formula, you could just activate the cell instead.
          frmlaR1C1 = Application.ConvertFormula(frmla, xlA1, xlR1C1, , ActiveCell)
          frmlaA1 = Application.ConvertFormula(frmlaR1C1, xlR1C1, xlA1, xlAbsolute, cel)
          boo = Application.Evaluate(frmlaA1)
        Else    'If "Value Is", then identify the type of comparison operator and build comparison formula
         
          Select Case .Item(i).Operator
            Case xlEqual ' = x
              frmla = cel & "=" & .Item(i).Formula1
            Case xlNotEqual ' <> x
              frmla = cel & "<>" & .Item(i).Formula1
            Case xlBetween 'x <= cel <= y
              frmla = "AND(" & .Item(i).Formula1 & "<=" & cel & "," & cel & "<=" & .Item(i).Formula2 & ")"
            Case xlNotBetween 'x > cel or cel > y
              frmla = "OR(" & .Item(i).Formula1 & ">" & cel & "," & cel & ">" & .Item(i).Formula2 & ")"
            Case xlLess ' < x
              frmla = cel & "<" & .Item(i).Formula1
            Case xlLessEqual ' <= x
              frmla = cel & "<=" & .Item(i).Formula1
            Case xlGreater ' > x
              frmla = cel & ">" & .Item(i).Formula1
            Case xlGreaterEqual ' >= x
              frmla = cel & ">=" & .Item(i).Formula1
          End Select
         
          boo = Application.Evaluate(frmla) 'Evaluate the "Value Is" comparison formula
        End If

        If boo Then 'If this Format Condition is satisfied
          On Error Resume Next
         
          Select Case Left(LCase(FormatType), 1)
            Case "f" 'Font color
              tmp = .Item(i).Font.ColorIndex
            Case Else 'Interior or highlight color
              tmp = .Item(i).Interior.ColorIndex
          End Select
          
          If Err = 0 Then ConditionalColor = tmp
         
          Err.Clear
          
          On Error GoTo 0
          Exit For 'Since Format Condition is satisfied, exit the inner loop
         
        End If
      Next i
    End With
End If
End Function

 

   

  评论这张
 
阅读(1761)| 评论(0)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017