堆栈内存溢出
  简体   繁体   English

VBA在Excel上给出错误

[英]VBA on excel giving error

 原文  2016-05-30 16:21:06  6   2    excel/ vba

问题描述

I have an excel which runs on following VBA code. 我有一个在以下VBA代码上运行的excel。 Till last month it was working perfect , but now giving error. 直到上个月为止，它的工作情况完美无缺，但现在出现了错误。 Please help to sort the problem 请帮助解决问题 

Sub SaveData()

    Dim i As Integer

    Clear
    Range("A1").Select

    For i = 1 To 1

        'Range("B4") = Cells(6 + i, 14)
        Range("F3") = "getting " & Range("B4")
        GetData
        Range("C7:Y95").Select
        Selection.Copy

        Sheets("FEED").Select
        Range("A1").Select
        ActiveSheet.Paste
        Sheets("Sheet2").Select

        Columns("Z:AV").Select
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlToLeft
        Sheets("Sheet2").Visible = False

        Sheets("FEED").Visible = False

        Sheets("MAIN").Select
        Range("AA2").Select
        ActiveWorkbook.Connections("Connection").Delete
        ActiveWorkbook.Connections("Connection1").Delete
        '    ActiveWorkbook.Connections("Connection2").Delete
        ' ActiveWorkbook.Connections("Connection3").Delete

        Exit Sub
        Range("I8:I300").Select
        Selection.Copy
        Cells(8, 14 + i).Select
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,     SkipBlanks:= _
            False, Transpose:=False
        Range("A1").Select
    Next i
    Range("F3") = ""
    Range("BF1").Select
    UpdateScale
    Colour
    Range("AY5").Select
End Sub

Sub GetData()

    Dim QuerySheet As Worksheet
    Dim DataSheet As Worksheet
    Dim EndDate As Date
    Dim StartDate As Date
    Dim Symbol As String
    Dim qurl As String
    Dim nQuery As Name


    Application.DisplayAlerts = False


    Set DataSheet = ActiveSheet

    StartDate = DataSheet.Range("B2").Value
    EndDate = DataSheet.Range("B3").Value
    Symbol = DataSheet.Range("B4").Value
    Range("C7").CurrentRegion.ClearContents



    qurl="http://www.nseindia.com/live_market/dynaContent/live_watch/option_chain/optionKeys.jsp?symbolCode=1309&symbol=" & Symbol
        qurl = qurl & "&symbol=" & Symbol & "&instrument=-&date=-&segmentLink=17&symbolCount=2&segmentLink=17"


    Range("b5") = qurl

 QueryQuote:
         With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl,     Destination:=DataSheet.Range("C7"))
            .BackgroundQuery = True
            .TablesOnlyFromHTML = False
            .REFRESH BackgroundQuery:=False
            .SaveData = True
        End With
        Exit Sub
        Range("C7").CurrentRegion.TextToColumns Destination:=Range("C7"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=True, Space:=False, other:=False

        Range(Range("C7"), Range("C7").End(xlDown)).NumberFormat = "mmm d/yy"
        Range(Range("D7"), Range("G7").End(xlDown)).NumberFormat = "0.00"
        Range(Range("H7"), Range("H7").End(xlDown)).NumberFormat = "0,000"
        Range(Range("I7"), Range("I7").End(xlDown)).NumberFormat = "0.00"


    With ThisWorkbook
        For Each nQuery In Names
            If IsNumeric(Right(nQuery.Name, 1)) Then
                nQuery.Delete
            End If
        Next nQuery
    End With

    'turn calculation back on
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Range("C7:I2000").Select
    Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("C1").Select
    Selection.ColumnWidth = 12

    '    UpdateScale

    Range("B4").Select

End Sub

Sub UpdateScale()
    Dim ChartVar As Chart
    Dim lMax As Long, lMin As Long

    On Error GoTo ScalingProblem
    'Assigns the values in the Min and Max ranges to variables.
    With Sheet1
        lMax = .Range("Max").Value
        lMin = .Range("Min").Value
        'Creates chart object.
        Set ChartVar = .ChartObjects("Chart 49").Chart

       With ChartVar.Axes(xlValue, xlPrimary)  'Adjusts the price axis
           .MinimumScale = lMin
           .MaximumScale = lMax
       End With

    End With
    Exit Sub

ScalingProblem:
    'RetrievalProblem:
    '    MsgBox "Unable to update chart scale.", vbCritical + vbOKOnly, "Scaling     Error"
End Sub

Sub Clear()
    '
    ' Clear Macro
    ' Macro recorded 3/13/2006 by Ponzo
    '

    '
    ActiveWindow.SmallScroll ToRight:=6
    Range("O8:X258").Select
    Selection.ClearContents
End Sub

Sub Colour()
    '
    ' Colour Macro
    ' Macro recorded 3/13/2006 by Ponzo

    Dim i As Integer, j As Integer, A As Double, B As Double, C As Double

    A = Range("AZ2")
    'B = Range("BA2")
    C = Range("BB2")

    For i = 1 To 10
        For j = 1 To 10

            If Cells(7 + i, 48 + j) < A Then
                Range("AZ3").Select
                Selection.Copy
                Cells(7 + i, 48 + j).Select
                Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,     SkipBlanks:= _
                    False, Transpose:=False
            End If

            If (Cells(7 + i, 48 + j) >= A And Cells(7 + i, 48 + j) <= C) Then
                Range("BA3").Select
                Selection.Copy
                Cells(7 + i, 48 + j).Select
                Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,     SkipBlanks:= _
                    False, Transpose:=False
            End If

            If Cells(7 + i, 48 + j) > C Then
                Range("BB3").Select
                Selection.Copy
                Cells(7 + i, 48 + j).Select
                Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,     SkipBlanks:= _
                    False, Transpose:=False
            End If
        Next j
    Next i

    For i = 1 To 10
        '    Cells(7 + i, 48 + i) = ""
        Cells(7 + i, 48 + i).Select
        With Selection.Interior
            .ColorIndex = 16
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
        End With
    Next i

    For i = 1 To 10
        For j = 1 To 10

            If Cells(20 + i, 48 + j) < A Then
                Range("AZ3").Select
                Selection.Copy
                Cells(20 + i, 48 + j).Select
                Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,     SkipBlanks:= _
                    False, Transpose:=False
            End If

            If (Cells(20 + i, 48 + j) >= A And Cells(20 + i, 48 + j) <= C) Then
                Range("BA3").Select
                Selection.Copy
                Cells(20 + i, 48 + j).Select
                Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,     SkipBlanks:= _
                    False, Transpose:=False
            End If

            If Cells(20 + i, 48 + j) > C Then
                Range("BB3").Select
                Selection.Copy
                Cells(20 + i, 48 + j).Select
                Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,     SkipBlanks:= _
                    False, Transpose:=False
            End If
        Next j
    Next i

    For i = 1 To 10
        '    Cells(20 + i, 48 + i) = ""
        Cells(20 + i, 48 + i).Select
        With Selection.Interior
            .ColorIndex = 16
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
        End With
    Next i
    Range("AY5").Select
End Sub

Sub REFRESH()
    '
    ' REFRESH Macro
    '

    '
    'Sheets("MAIN").Select
    Sheets("Sheet2").Visible = True
    'Sheets("MAIN").Select
    Sheets("FEED").Visible = True
    Sheets("Sheet2").Select
    SaveData
End Sub

2 个解决方案

解决方案1
 0  2016-06-10 01:11:03

Just Try this 试试这个

Go to START and in the RUN line type REGEDIT. 转到“开始”，然后在“运行”行中键入REGEDIT。

b. b。 In the registry navigate to 在注册表中导航到

HKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings HKEY_CURRENT_USER \\ Software \\ Microsoft \\ Windows \\ CurrentVersion \\ Internet设置

c. C。 Right click Internet Settings and left click New > DWORD Value (32-bit) and name the new value “BypassSSLNoCacheCheck” without the quotes. 右键单击“ Internet设置”，然后单击“新建> DWORD值（32位）”，然后将新值命名为“ BypassSSLNoCacheCheck”（不带引号）。 Double click this value and give it a value of 1. 双击此值并将其值设置为1。

解决方案2
 0  2017-03-09 05:33:47

Sub SaveData() 子SaveData（） 

Dim i As Integer

Clear
Range("A1").Select

For i = 1 To 1

    'Range("B4") = Cells(6 + i, 14)
    Range("F3") = "getting " & Range("B4")
    GetData
    Range("C7:Y95").Select
    Selection.Copy

    Sheets("FEED").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Sheet2").Select

    Columns("Z:AV").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Sheets("Sheet2").Visible = False

    Sheets("FEED").Visible = False

    Sheets("MAIN").Select
    Range("AA2").Select
    ActiveWorkbook.Connections("Connection").Delete
    ActiveWorkbook.Connections("Connection1").Delete
    '    ActiveWorkbook.Connections("Connection2").Delete
    ' ActiveWorkbook.Connections("Connection3").Delete

    Exit Sub
    Range("I8:I300").Select
    Selection.Copy
    Cells(8, 14 + i).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Range("A1").Select
Next i
Range("F3") = ""
Range("BF1").Select
UpdateScale
Colour
Range("AY5").Select

End Sub 结束子

Sub GetData() 子GetData（） 

Dim QuerySheet As Worksheet
Dim DataSheet As Worksheet
Dim EndDate As Date
Dim StartDate As Date
Dim Symbol As String
Dim qurl As String
Dim nQuery As Name


Application.DisplayAlerts = False


Set DataSheet = ActiveSheet

StartDate = DataSheet.Range("B2").Value
EndDate = DataSheet.Range("B3").Value
Symbol = DataSheet.Range("B4").Value
Range("C7").CurrentRegion.ClearContents



qurl = "http://www.nseindia.com/live_market/dynaContent/live_watch/option_chain/optionKeys.jsp?symbolCode=1309&symbol=" & Symbol
    qurl = qurl & "&symbol=" & Symbol & "&instrument=-&date=-&segmentLink=17&symbolCount=2&segmentLink=17"


Range("b5") = qurl

QueryQuote: With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("C7")) .BackgroundQuery = True .TablesOnlyFromHTML = False .REFRESH BackgroundQuery:=False .SaveData = True End With Exit Sub Range("C7").CurrentRegion.TextToColumns Destination:=Range("C7"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=True, Space:=False, other:=False QueryQuote：使用ActiveSheet.QueryTables.Add（Connection：=“ URL;”＆qurl，目标：= DataSheet.Range（“ C7”））。BackgroundQuery = True .TablesOnlyFromHTML = False .REFRESH BackgroundQuery：= False .SaveData = True结束使用Exit Sub Range（“ C7”）。CurrentRegion.TextToColumns目标：= Range（“ C7”），DataType：= xlDelimited，_ TextQualifier：= xlDoubleQuote，ConsecutiveDelimiter：= False，Tab：= True，_分号：= False，逗号：= True，空格：= False，其他：= False 

    Range(Range("C7"), Range("C7").End(xlDown)).NumberFormat = "mmm d/yy"
    Range(Range("D7"), Range("G7").End(xlDown)).NumberFormat = "0.00"
    Range(Range("H7"), Range("H7").End(xlDown)).NumberFormat = "0,000"
    Range(Range("I7"), Range("I7").End(xlDown)).NumberFormat = "0.00"


With ThisWorkbook
    For Each nQuery In Names
        If IsNumeric(Right(nQuery.Name, 1)) Then
            nQuery.Delete
        End If
    Next nQuery
End With

'turn calculation back on
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Range("C7:I2000").Select
Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("C1").Select
Selection.ColumnWidth = 12

'    UpdateScale

Range("B4").Select

End Sub 结束子

Sub UpdateScale() Dim ChartVar As Chart Dim lMax As Long, lMin As Long Sub UpdateScale（）昏暗的ChartVar视图表的昏暗lMax的长度，lMin的长度 

On Error GoTo ScalingProblem
'Assigns the values in the Min and Max ranges to variables.
With Sheet1
    lMax = .Range("Max").Value
    lMin = .Range("Min").Value
    'Creates chart object.
    Set ChartVar = .ChartObjects("Chart 49").Chart

   With ChartVar.Axes(xlValue, xlPrimary)  'Adjusts the price axis
       .MinimumScale = lMin
       .MaximumScale = lMax
   End With

End With
Exit Sub

ScalingProblem: 'RetrievalProblem: ' MsgBox "Unable to update chart scale.", vbCritical + vbOKOnly, "Scaling Error" End Sub ScalingProblem：'RetrievalProblem：'MsgBox“无法更新图表比例。”，vbCritical + vbOKOnly，“ Scaling Error” End Sub

Sub Clear() ' ' Clear Macro ' Macro recorded 3/13/2006 by Ponzo ' Sub Clear（）''Clear Macro'宏录制于3/13/2006，由Ponzo' 

'
ActiveWindow.SmallScroll ToRight:=6
Range("O8:X258").Select
Selection.ClearContents

End Sub 结束子

Sub Colour() ' ' Colour Macro ' Macro recorded 3/13/2006 by Ponzo Sub Colour（）''Color Macro'Ponzo录制3/13/2006宏 

Dim i As Integer, j As Integer, A As Double, B As Double, C As Double

A = Range("AZ2")
'B = Range("BA2")
C = Range("BB2")

For i = 1 To 10
    For j = 1 To 10

        If Cells(7 + i, 48 + j) < A Then
            Range("AZ3").Select
            Selection.Copy
            Cells(7 + i, 48 + j).Select
            Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=False
        End If

        If (Cells(7 + i, 48 + j) >= A And Cells(7 + i, 48 + j) <= C) Then
            Range("BA3").Select
            Selection.Copy
            Cells(7 + i, 48 + j).Select
            Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=False
        End If

        If Cells(7 + i, 48 + j) > C Then
            Range("BB3").Select
            Selection.Copy
            Cells(7 + i, 48 + j).Select
            Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=False
        End If
    Next j
Next i

For i = 1 To 10
    '    Cells(7 + i, 48 + i) = ""
    Cells(7 + i, 48 + i).Select
    With Selection.Interior
        .ColorIndex = 16
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
Next i

For i = 1 To 10
    For j = 1 To 10

        If Cells(20 + i, 48 + j) < A Then
            Range("AZ3").Select
            Selection.Copy
            Cells(20 + i, 48 + j).Select
            Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=False
        End If

        If (Cells(20 + i, 48 + j) >= A And Cells(20 + i, 48 + j) <= C) Then
            Range("BA3").Select
            Selection.Copy
            Cells(20 + i, 48 + j).Select
            Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=False
        End If

        If Cells(20 + i, 48 + j) > C Then
            Range("BB3").Select
            Selection.Copy
            Cells(20 + i, 48 + j).Select
            Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=False
        End If
    Next j
Next i

For i = 1 To 10
    '    Cells(20 + i, 48 + i) = ""
    Cells(20 + i, 48 + i).Select
    With Selection.Interior
        .ColorIndex = 16
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
Next i
Range("AY5").Select

End Sub 结束子

Sub REFRESH() ' ' REFRESH Macro ' Sub REFRESH（）''REFRESH宏' 

'
'Sheets("MAIN").Select
Sheets("Sheet2").Visible = True
'Sheets("MAIN").Select
Sheets("FEED").Visible = True
Sheets("Sheet2").Select
SaveData

End Sub 结束子

暂无
暂无

声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

相关问题 Excel VBA在调试模式下未提供错误消息 - Excel VBA not giving error messages in debug mode Excel VBA 正则表达式模式给出错误'5018' - Excel VBA regex pattern giving error '5018' Excel VBA宏给我一个溢出错误6 - Excel VBA macro is giving me an overflow error 6 用于连接的Excel VBA UDF提供了一条错误消息 - Excel VBA UDF for concatenating is giving an Error message Excel VBA - VBA中的日期和IF函数发出错误 - Excel VBA - Date and IF Function inside the VBA is giving an error Isnumber在Excel VBA中将错误定义为对象定义错误 - Isnumber is giving error as Object defined error in Excel VBA 插入功能在Excel宏VBA中给出1004错误 - Insert function is giving 1004 error in excel macro vba Excel VBA 自定义函数给出“引用无效”错误 - Excel VBA Custom Function giving “Reference Not Valid” Error 为什么Excel VBA给我一个动态范围错误？ - Why is Excel VBA giving me an error for a dynamic Range? EXCEL-VBA记录的宏给出运行时错误“ 1004” - EXCEL - VBA recorded macro giving runtime error “1004”
相关标签
 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM