Question

无法在任何地方找到解决方案。我使用Web Query下载了大约500种股票的股票数据。它最终会在下载整个库存清单之前挂起，我将不得不进行最终处理。如果我将列表分成3个独立的部分，它就可以工作。我已经修改了清除缓存的频率，但它还没有解决问题。任何帮助将不胜感激！

Private Sub Download_Click()
Dim i As Long, j As Long, STEnd As Long, STArray As Variant, TempSht As String, ST As String, SH As Worksheet
Dim symbols As String, sline As String, Values As Variant
Dim W As Worksheet: Set W = ActiveSheet
Dim ResearchSht As Worksheet: Set ResearchSht = ThisWorkbook.Sheets("Research")
Dim Last As Long

   Application.DisplayAlerts = False
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculateManual

TempSht = "Template"

'Delete Old Sheets
For Each SH In ThisWorkbook.Sheets
Select Case SH.Name
    Case ResearchSht.Name, "Template", "Trades"
    Case Else
        SH.Delete
End Select
Next

Last = ResearchSht.Cells(Rows.Count, 1).End(xlUp).Row
If Last = 1 Then Exit Sub
For j = 2 To Last
    ST = UCase(Trim(ResearchSht.Cells(j, 1)))
    ResearchSht.Cells(j, 1) = ST
    Worksheets.Add.Name = ST
    Select Case ST
        Case "^GSPC"
            SD = Day(Now)
            SM = Month(Now) - 1
            SY = Year(Now) - 10
            SY_2 = Year(Now)
        Case Else
            Check_Date
    End Select

    With ActiveSheet.QueryTables.Add(Connection:="URL;http://ichart.finance.yahoo.com/table.csv?s=" & ST & "&d=" & SM & "&e=" & SD & "&f=" & SY_2 & "&g=d&a=" & SM & "&b=" & SD & "&c=" & SY, Destination:=Sheets(ST).Range("$A$1"))
        .Name = ST
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "1,2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With

    'Split CSV data into columns
    STEnd = Sheets(ST).Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To STEnd - 1
        STArray = Split(Sheets(ST).Cells(i, 1), ",")
        Sheets(ST).Cells(i, 1).Value = STArray(0)
        Sheets(ST).Cells(i, 2).Value = STArray(1)
        Sheets(ST).Cells(i, 3).Value = STArray(2)
        Sheets(ST).Cells(i, 4).Value = STArray(3)
        Sheets(ST).Cells(i, 5).Value = STArray(4)
        Sheets(ST).Cells(i, 6).Value = STArray(5)
        Sheets(ST).Cells(i, 7).Value = STArray(6)
    Next
    Sheets(TempSht).Range("H:AU").Copy Destination:=Sheets(ST).Range("H1")
    Application.Calculation = xlCalculationAutomatic
    Sheets(ST).Range("H:AL").Copy
    Sheets(ST).Range("H1").PasteSpecial Paste:=xlValues
    Application.Calculation = xlCalculateManual
    Sheets(ST).Cells.EntireColumn.AutoFit
    ActiveSheet.Visible = xlSheetHidden

  Select Case j
      Case 10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 210, 220, 230, 240, 250, 260, 270, 280, 290, 300, 310, 320, 330, 340, 350, 360, 370, 380, 390, 400, 410, 420, 430, 440, 450, 460, 470, 480, 490, 500, 510, 520, 530, 540, 550, 560, 570, 580, 590, 600, 610, 620, 630, 640, 650, 660, 670, 680, 690, 700, 710, 720, 730, 740, 750, 760, 770, 780, 790, 800, 810, 820, 830, 840, 850, 860, 870, 880, 890, 900, 910, 920, 930, 940, 950, 960, 970, 980, 990, 1000, 1010
          Shell "RunDll32.exe InetCpl.Cpl,ClearMyTracksByProcess 8"
  End Select
  'If ST <> "^GSPC" Then Sheets(ST).Delete 'Test
Next

ResearchSht.Activate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True

VBA多个Web查询在清除缓存后仍然挂起

0 个答案: