Sub zakupki()
On Error Resume Next

For i = 3763444 To 7193186
    k = k + 1
    Sheets("Áàçà").Cells(LastRow + 1, 1) = "Êàðòî÷êà íîìåð: " & i
    Sheets("Áàçà").Cells(1, 1) = k & " èç " & 7193186 - 3763444
    LastRow = Sheets("Áàçà").Range("A1").SpecialCells(xlLastCell).Row
    temp = 1
    While temp = 1
        If Sheets("Áàçà").Cells(LastRow, 1) = "" Then
            LastRow = LastRow - 1
            temp = 1
        Else
            temp = 0
        End If
    Wend
    Sheets("Áàçà").Cells(1, 2) = LastRow

    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & "http://zakupki.gov.ru/pgz/public/action/contracts/info/common_info/show?contractInfoId=" & i _
        , Destination:=Sheets("Áàçà").Cells(LastRow + 1, 1))
        .Name = "show?contractId=5379220"
        .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 = "20"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
Next i
End Sub