cnCalc计算器论坛

 找回密码
 注册
搜索
查看: 2876|回复: 1

哪位大大帮看一下这个宏是什么意思?

[复制链接]
发表于 2011-9-18 16:29:39 | 显示全部楼层 |阅读模式
Excel里的,我搞了半天愣是搞不对,他到底是什么要求啊
Function ExistSheet(ByVal name As String) As Boolean
         Dim flag As Boolean
         flag = True
         On Error GoTo 10
           Sheets(name).Select
           ExistSheet = flag
           Exit Function
10
           flag = False
           Resume Next
         
End Function
Function ExistChart(ByVal name As String) As Boolean
         Dim flag As Boolean
         flag = True
         On Error GoTo 10
           
           Charts(name).Select
           
           ExistChart = flag
           Exit Function
10
           flag = False
           Resume Next
End Function

Function CheckCellFormat(ByVal SheetName, CellName, CheckFormat As String) As Boolean
          Sheets(SheetName).Select
          Range(CellName).Select
          If Selection.NumberFormatLocal <> CheckFormat Then
              
              
              CheckCellFormat = False
              
          Else
             CheckCellFormat = True
          End If
End Function
Sub SetCellValue(ByVal SheetName, CellName, CellValue As String)
     Sheets(SheetName).Select
     Range(CellName).Select
     ActiveCell.FormulaR1C1 = CellValue
     
End Sub
Function GetCellValue(ByVal SheetName, ByVal CellName As String) As String
     Dim oldvalue As String
     
     Sheets(SheetName).Select
     Range(CellName).Select
     
     oldvalue = Selection.NumberFormatLocal
     Selection.NumberFormatLocal = "@"
     GetCellValue = ActiveCell.FormulaR1C1
     Selection.NumberFormatLocal = oldvalue
     
End Function
Function ColCheckFormula(ByVal SheetName, Startcol As String, ByVal rowi, rowj As Long, ByVal Formula As String) As Boolean
         Dim i As Long
         If Not ExistSheet(SheetName) Then
   
              MsgBox " 不存在工作表“" & SheetName, vbOKOnly
          End If
          ' coli  <=colj
         ColCheckFormula = True
         For i = rowi To rowj
            If (GetCellValue(SheetName, Startcol & i) <> Formula) Then
            
               ColCheckFormula = False
            End If
         Next i
End Function
Function RowCheckFormula(ByVal SheetName, Startrow As String, ByVal coli, colj As String, ByVal Formula As String) As Boolean
         Dim i As Long
         If Not ExistSheet(SheetName) Then
   
              MsgBox " 不存在工作表“" & SheetName, vbOKOnly
          End If
          ' coli  <=colj
         RowCheckFormula = True
         For i = Asc(coli) To Asc(colj)
            
            If (GetCellValue(SheetName, Chr(i) & Startrow) <> Formula) Then
            
               RowCheckFormula = False
            End If
         Next i
End Function

Sub FA()
  Dim ok As Boolean
  ok = True
  If Not RowCheckFormula("F", 16, "D", "H", "=R[-3]C-R[-2]C-R[-1]C") Then ok = False
  
  If ok Then
    SetCellValue "F", "A2", "对"
  Else
   SetCellValue "F", "A2", "错"
  End If

End Sub

Sub FB()
  Dim ok As Boolean
  ok = True
  
  If GetCellValue("F", "D17") <> "0" Then ok = False
  If Not RowCheckFormula("F", 17, "E", "H", "=(R[-1]C-R[-1]C[-1])/R[-1]C[-1]") Then ok = False
  
  If ok Then
    SetCellValue "F", "A3", "对"
  Else
   SetCellValue "F", "A3", "错"
  End If
End Sub

Sub FC()
  Dim ok As Boolean
  ok = True
  
   For i = Asc("D") To Asc("H")
       If Not CheckCellFormat("F", Chr(i) & 17, "0.00%") Then
          ok = False
          Exit For
        End If
   Next i

  
  If ok Then
    SetCellValue "F", "A4", "对"
  Else
   SetCellValue "F", "A4", "错"
  End If
End Sub

Sub FD()
    Dim ok As Boolean
   
    ok = True
    Sheets("F").Select
    Range("B12").Select
   
   
    If Selection.Font.ColorIndex <> 2 Then ok = False
    If Selection.Font.Color <> 16777215 Then ok = False
   
  
    Range("F15").Select
   
   
    If Selection.Font.ColorIndex <> 11 Then ok = False
    If Selection.Font.Color <> 8388608 Then ok = False
   
    If ok Then
       SetCellValue "F", "A5", "对"
    Else
       SetCellValue "F", "A5", "错"
    End If
   
End Sub

Sub FE()
  Dim ok As Boolean
  ok = True
  
  If Not ExistChart("Chart1") Then ok = False
  
  If ok Then
   Charts("Chart1").Select
  If ok And Not (ActiveChart.ChartType = xlColumnClustered) Then ok = False
  If ok And ActiveChart.SeriesCollection.Count <> 4 Then ok = False
  
  
   
  If ok Then
     For i = 1 To 4
          x = ActiveChart.SeriesCollection(i).Formula
          If i = 1 And x <> "=SERIES(F!$B$13,F!$C$12:$H$12,F!$C$13:$H$13,1)" Then
             ok = False
             Exit For
          End If
           If i = 2 And x <> "=SERIES(F!$B$14,F!$C$12:$H$12,F!$C$14:$H$14,2)" Then
             ok = False
             Exit For
          End If
           If i = 3 And x <> "=SERIES(F!$B$15,F!$C$12:$H$12,F!$C$15:$H$15,3)" Then
             ok = False
             Exit For
          End If
           If i = 4 And x <> "=SERIES(F!$B$16,F!$C$12:$H$12,F!$C$16:$H$16,4)" Then
             ok = False
             Exit For
          End If
     Next i
   
  End If
  
  With ActiveChart
        
        If ok And .HasTitle <> True Then ok = False
        If ok And .ChartTitle.Characters.Text <> "公司情况表" Then ok = False
        If ok And .Axes(xlCategory, xlPrimary).HasTitle <> True Then ok = False
        If ok And .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text <> "年份" Then ok = False
        If ok And .Axes(xlValue, xlPrimary).HasTitle <> True Then ok = False
        If ok And .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text <> "金额(万)" Then ok = False
        
        If ok And ActiveChart.HasLegend <> True Then ok = False
        ActiveChart.Legend.Select
        If ok And Selection.Position <> xlRight Then ok = False
        
    End With
  
  
  End If
  If ok Then
    SetCellValue "F", "A6", "对"
  Else
   SetCellValue "F", "A6", "错"
  End If
End Sub

Sub FF()
  Dim ok As Boolean
  ok = True
  If Not ExistChart("Chart1") Then ok = False
  
  If ok Then
    Charts("Chart1").Select

  
  If ok Then
      ActiveChart.ChartTitle.Select
      Selection.AutoScaleFont = True
      x = Selection.Font.ColorIndex
      With Selection.Font
        
        If ok And .name <> "黑体" Then ok = False
        If ok And .Size <> 22 Then ok = False
        If ok And Selection.Font.Bold <> True Then ok = False
        If ok And .ColorIndex <> 5 Then ok = False
        
    End With
  End If
  If ActiveChart.Axes.Count <> 2 Then ok = False
  If ok Then
   
    ActiveChart.Axes(xlValue).Select
    With ActiveChart.Axes(xlValue)
      
        If ok And .MaximumScale <> 1600 Then ok = False
        If ok And .MajorUnit <> 100 Then ok = False
        
    End With
  End If
  End If
  
  If ok Then
    SetCellValue "F", "A8", "对"
  Else
   SetCellValue "F", "A8", "错"
  End If
End Sub

Sub FG()
  
  Dim ok As Boolean
  ok = True
  If ActiveSheet.ChartObjects.Count <> 1 Then ok = False
  If ok Then
     Dim x As ChartObject
     Set x = ActiveSheet.ChartObjects(1)
     x.Activate
     If (ActiveSheet.Shapes(x.name).BottomRightCell.Column <> 16) Or (ActiveSheet.Shapes(x.name).BottomRightCell.Row <> 24) Then ok = flase
     
     If (ActiveSheet.Shapes(x.name).TopLeftCell.Column <> 10) Or (ActiveSheet.Shapes(x.name).TopLeftCell.Row <> 12) Then ok = flase
     
     If ActiveChart.ChartType <> xlLineMarkers Then ok = False
     
     If ok Then
        With ActiveChart
           If (Not .HasTitle = True Or Not .ChartTitle.Characters.Text = "利润年增长率") Then ok = False
         End With
     End If
   
     
     If ActiveChart.Axes.Count = 2 Then
   
        ActiveChart.Axes(xlValue).Select
        With ActiveChart.Axes(xlValue)
         
           If ok And .MaximumScale <> 0.6 Then ok = False
           If ok And .MajorUnit <> 0.05 Then ok = False
        
         End With
     End If
     
     If ok And ActiveChart.SeriesCollection.Count <> 1 Then ok = False
  
  
   
    If ok Then
     For i = 1 To 1
          y = ActiveChart.SeriesCollection(i).Formula
          If i = 1 And y <> "=SERIES(F!$B$17,F!$C$12:$H$12,F!$C$17:$H$17,1)" Then
             ok = False
             Exit For
          End If
           If i = 2 And y <> "=SERIES(F!$B$14,F!$C$12:$H$12,F!$C$14:$H$14,2)" Then
             ok = False
             Exit For
          End If
           If i = 3 And y <> "=SERIES(F!$B$15,F!$C$12:$H$12,F!$C$15:$H$15,3)" Then
             ok = False
             Exit For
          End If
           If i = 4 And y <> "=SERIES(F!$B$16,F!$C$12:$H$12,F!$C$16:$H$16,4)" Then
             ok = False
             Exit For
          End If
     Next i
   
  End If
     
     
     
     
  End If
  
  
  
  If ok Then
    SetCellValue "F", "A9", "对"
  Else
   SetCellValue "F", "A9", "错"
  End If
End Sub



Excel里的要求是以B12:H12,B17:H17为数据源生成图表:数据点折线图,最大刻度为0.6,主要刻度为0.05图表放在当前工作表的J12:P24区域内。
 楼主| 发表于 2011-9-18 16:37:31 | 显示全部楼层
恩,附上原件

Excel电子表格操作要求.xls

231 KB, 下载次数: 16

您需要登录后才可以回帖 登录 | 注册

本版积分规则

Archiver|手机版|cnCalc计算器论坛

GMT+8, 2024-12-5 10:05 , Processed in 0.093020 second(s), 26 queries .

Powered by Discuz! X3.4

© 2001-2023 Discuz! Team.

快速回复 返回顶部 返回列表