Allineamento archivio Lotto

Hai un problema con Excel?

Nuova discussione

Allineamento archivio Lotto
di Michele (utente non iscritto) data: 26/08/2016 00:35:39
Mi sembrava facile , ma è un mese che ci provo senza nessun risultato

Devo copiare l'archivio lotto dal foglio1 al foglio2 , allineato come si vede nel foglio3

Allego il File esempio

Ringrazio tutti in particolare chi è in grado di farlo

di Raffaele_53 data: 26/08/2016 03:57:15
Codice da mettere in un modulo

Premessa vai sul Foglio1
Seleziona colonna B, Home/trova e seleziona/sostituisci TO con TR
Seleziona colonna C, Home/ borda la colonna solo sulla sinistra
Seleziona colonna G, Home/ borda la colonna solo sulla destra
Elimina il bottone ed inserisci un bottone non activeX
Sul Foglio2, seleziona la colonna B, formatto generale

Option Explicit
Sub archivia()
Dim sh1 As Worksheet: Set sh1 = Worksheets("Foglio1")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Foglio2")
Dim X, Ur, Y, Rg, Tot
Ur = sh1.Range("A" & Rows.Count).End(xlUp).Row
Rg = 3
Application.ScreenUpdating = False
For X = 1 To Ur
Tot = Application.WorksheetFunction.CountIf(sh1.Range("A:A"), sh1.Cells(X, 1).Value)
sh2.Cells(Rg, 1) = sh1.Cells(X, 1)
sh2.Cells(Rg, 2) = Rg - 2
    For Y = 1 To Tot
        Select Case sh1.Cells(X, 2)
        Case "BA"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 3).PasteSpecial
        Case "CA"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 8).PasteSpecial
        Case "FI"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 13).PasteSpecial
        Case "GE"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 18).PasteSpecial
        Case "MI"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 23).PasteSpecial
        Case "NA"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 28).PasteSpecial
        Case "PA"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 33).PasteSpecial
        Case "RM"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 38).PasteSpecial
        Case "TR"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 43).PasteSpecial
        Case "VE"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 48).PasteSpecial
        Case "RN"
            sh1.Range(sh1.Cells(X, 3), sh1.Cells(X, 7)).Copy
            sh2.Cells(Rg, 53).PasteSpecial
        End Select
        If Y <> Tot Then X = X + 1
    Next Y
    Rg = Rg + 1
Next X
Application.ScreenUpdating = True
Set sh1 = Nothing
Set sh2 = Nothing
MsgBox "fatto"
End Sub

di Michele (utente non iscritto) data: 26/08/2016 16:30:15
Ciao Raffaele

La macro funziona benissimo , unico problema è che è un po lenta ad aggiornare il foglio impiga circa 5 minuti...... bisognerebbe ridurre questo tempo di almeno 10 volte
di Raffaele_53 data: 26/08/2016 20:39:13
Hai spostato un allegato
A me l'ha fatto in 5/10 secondi (non vedo altri modi per migliorarlo)

I casi sono due:
Hai un PC vecchio che è ora di cambiare oppure hai pure formule inserite.
In questo caso vedi--->Application.Calculation = xlCalculationManual
di Michele (utente non iscritto) data: 28/08/2016 13:24:57
Ho fatto le modifiche ma non è cambiato nulla sicuramente è il PC troppo vecchio proverò con quello di qualche amico ciao grazie

di Vecchio Frac data: 29/08/2016 10:41:19
Perchè parlate di tempi così lunghi? La mia macchina non è un mostro di guerra e (sulla base del file che è allegato) ci mette poco meno di cinque secondi (sì, ho modificato leggermente il codice proposto, ma la sostanza non cambia).

Option Explicit

Sub archivia()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim X As Long, Ur As Long, Y As Long, Rg As Long, Tot As Long
Dim m As String, idx As Integer
    
    Set sh1 = Worksheets("Foglio1")
    Set sh2 = Worksheets("Foglio2")
    Ur = Range("A" & Rows.Count).End(xlUp).Row
    Rg = 3
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    sh1.Select
    
    m = "BA CA FI GE MI NA PA RM TR VE RN"
    
    For X = 1 To Ur
        Tot = WorksheetFunction.CountIf(Range("A:A"), Cells(X, 1).Value)
        sh2.Cells(Rg, 1) = sh1.Cells(X, 1)
        sh2.Cells(Rg, 2) = Rg - 2
        For Y = 1 To Tot
            idx = Choose(1  3 + 1, 3, 8, 13, 18, 23, 28, 33, 38, 43, 48, 53)
            Range(Cells(X, 3), Cells(X, 7)).Copy sh2.Cells(Rg, idx)
            If Y <> Tot Then X = X + 1
        Next Y
        Rg = Rg + 1
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
MsgBox "fatto"
End Sub

di Michele (utente non iscritto) data: 29/08/2016 12:57:45
Si è piu veloce ma scrive solamente la ruota di Bari, ma sta di fatto che il File esempio che ho postato è stato spezzato, altrimenti per via della sua dimensione non era possibile caricarlo , il File Storico scaricato dal sito Lottomatica è molto piu grande. Io credo che bisogna cambiare tutto , perchè il problema sta nel'ordinare il File Storico.txt

Vuoi Approfondire?