برنامج جلب ترددات أهم الفنوات

البرنامج تم إعداده في بيئة إكسل حيث يتبح لأي شخص يستعمله الحصول على ترددات القثنوات في جدول خاص (شيت يسمى) Frequence
وعلى مستعملي البرنامج لابد أن  يكونون متصلين بالناث

مصدر البرنامج

Sub XlsMilev()
'
' Macro1 Macro
' Macro enregistrée le 10/01/2017 par XlsMILEV
'

'
' DESACTIVER SECEEN
Application.ScreenUpdating = False
On Error Resume Next
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Dim nabil1 As String
Dim nabil2 As String

Sheets("sat").Select
nabil1 = Range("Q25")
nabil2 = Range("P22")


    Sheets("Frequences").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
  
 
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & nabil1, Destination:=Range("A1"))
        .Name = "XlsMilev"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Rows("2:26").Select
    Selection.Delete Shift:=xlUp
    Columns("D:I").Select
    Selection.Delete Shift:=xlToLeft
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Range("A1:C1355").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("A1:B1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
     Range("C1").Select
    ActiveCell.FormulaR1C1 = nabil2
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=TODAY()"
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:C1").Select
    With Selection.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
    End With
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Arial"
        .Size = 14
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Columns("C:C").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
    Range("A1:B1").Select
End Sub

تحميل البرنامج