You are here:Home-Domande su Excel Generale-CORTESIA-Rispondi a: CORTESIA
Rispondi a: CORTESIA2020-02-06T17:48:03+01:00

Home Forum Domande su Excel Generale CORTESIA Rispondi a: CORTESIA

BySalvBySalv
Amministratore del forum
    Post totali: 693

    Ciao Giorgio io uso questa macro

    Public sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, sh5 As Worksheet
    Public rr, Rt, rG, Rc, cc, S1
    
    Sub SetFG()
    Set sh1 = Worksheets("Ambate")
    Set sh2 = Worksheets("Appo2")
    Set sh3 = Worksheets("Appoggio")
    Set sh4 = Worksheets("Archivio")
    Set sh5 = Worksheets("Gest")
    End Sub
    Sub Lotto() 'aggiornamento internet
    Dim r, c, r1, r2, x, y, z, rx, rk, cx, c1, n, dd, ds, wd, ss, dat()
    
    SetFG
    sNo
    sh3.Visible = True
    sh3.Activate
    sh3.Cells.ClearContents
    On Error GoTo 1
        With ActiveSheet.QueryTables.Add(Connection:= _
            "URL;https://www.lottoced.com/lotto", Destination:=Range("$A$1"))
    '        .CommandType = 0
            .Name = "lotto_1"
            .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
        r1 = sh3.Cells(Rows.Count, 1).End(xlUp).Row
        r2 = sh4.Cells(Rows.Count, 1).End(xlUp).Row
        For x = 1 To r1
            If sh3.Cells(x, 1) = "BARI" Then
                ss = Split(sh3.Cells(x - 1, 1), " ")
                dd = CDate(ss(3) & "/" & ss(2) & "/" & ss(1))
                If sh4.Cells(r2, 2) = dd Then GoTo 1 Else r2 = r2 + 1
                sh4.Cells(r2, 1) = sh4.Cells(r2 - 1, 1) + 1
                sh4.Cells(r2, 2) = dd
                If Month(sh4.Cells(r2, 2)) <> Month(sh4.Cells(r2 - 1, 2)) Then
                  sh4.Cells(r2, 59) = 1
                  sh4.Cells(r2, 60) = 1
                  sh4.Cells(r2, 83) = 1
    '              sh2.Cells(10, 3) = 1
                Else
                  sh4.Cells(r2, 59) = sh4.Cells(r2 - 1, 59) + 1
                  sh4.Cells(r2, 60) = sh4.Cells(r2 - 1, 60) + 1
                  sh4.Cells(r2, 83) = sh4.Cells(r2 - 1, 83) + 1
    '              sh2.Cells(10, 3) = sh4.Cells(r2 - 1, 60) + 1
                End If
                
                c1 = 3
                n = 0
                For y = x To x + 10
                    For z = 2 To 6
                        sh4.Cells(r2, c1) = sh3.Cells(y, z)
                        c1 = c1 + 1
                    Next z
                Next y
                Exit For
            End If
        Next x
        sh1.Cells(1, 9) = 0
    '    sh2.Cells(1, 47) = 0
    '    sh6.Cells(1, 47) = 0
    MsgBox "Estrazione Inserita", vbInformation, "Scrittura dati"
    1:
    sh1.Activate
    sSi
    End Sub

    non so riuscirai comunque aggiungi i fogli come sono nominati in SetFg(), basta lanciare solo la macro lotto.

    ciao by sal

    Ciao By Sal (8-)
    se ti piace la soluzione aiuta a sostenere il Forum con una DONAZIONE a piacere, Grazie