Sviluppare funzionalita su Microsoft Office con VBA funzione Application.ScreenUpdating che non funziona.

Login Registrati
Stai vedendo 3 articoli - dal 1 a 3 (di 3 totali)
  • Autore
    Articoli
  • #30722 Score: 0 | Risposta

    mflauto
    Partecipante

      Buongiorno a tutti,

      ho creat una macro che mi filtra una notevole quantità di dati dal foglio:"FIRIngressi" al foglio:"ChecIN",

      ho inserto prima e all'interno del codice  l'istruzione                                 ed alla fine del codice l'istruzione

      ma quando eseguo la macro invece di rimanere lo schermo bianco visualizzo sempre dei dati.

      C'è un modo per far si che io visualizzi solo lo schermo bianco e magari anche con una clessidra che gira per non annoiare chi attende?

      In allegato la macro ed il file di esempio.

      Grazie per l'aiuto.

      Massimiliano

      Option Explicit
      
      Public Sub Formatta_Ingressi()
      
          Application.ScreenUpdating = False
          If MsgBox("Eseguire Copia & Formatta?", vbYesNo) = vbNo Then 'seve per interrompere la macro nle caso si scriva "no"
          Exit Sub
          End If
          ActiveSheet.Unprotect ("pippo01") 'toglie la protezione al foglio di lavoro
          Dim WB As Workbook
          Dim srcSH As Worksheet, destSH As Worksheet
          Dim srcRng As Range, destRng As Range
          Dim Rng As Range, rArea As Range
          Dim LRow As Long
          Dim CalcMode As Long
          Dim sPrimaCellaDestinazione As String
          Dim ur As Long
          Application.ScreenUpdating = False
          Const sFoglioSorgente As String = "FirIngressi"               '<<=== copia dal foglio sorgente
          Const sFoglioDestinazione As String = "CheckIN"       '<<=== al foglio destinazione
          Const sColonneDaCopiare As String = "A2:H2"                '<<=== il range di celle che deve esssere copiato
          'sPrimaCellaDestinazione = InputBox("Inserire i Riferimenti della Cella dove verranno Copiati i Dati?")   'chiedo la cella dove incollare i dati del foglio SorgenteDati
          Application.ScreenUpdating = False
         'Windows("FirIngressi").Activate
          Application.ScreenUpdating = False
          Worksheets("FirIngressi").Activate ' attiva il foglio "DESTINAZIONE Dati"
          Range("B:D,F:R,T:V,X:X,Z:Z,AC:AG,AI:BA").EntireColumn.Delete                               'elimina le colone selezionate
          Application.ScreenUpdating = False
          Range("E1:E10000,H1:H10000").NumberFormat = "#,0"                      'formatta le colonne "F" e "I" senza numeri decimali e con il separatore di virgole
          Application.ScreenUpdating = False
          Range("A1:H1").Select
          Columns("A:A").EntireColumn.AutoFit 'allarga le colonne
          Columns("B:B").EntireColumn.AutoFit 'allarga le colonne
          Columns("C:C").EntireColumn.AutoFit 'allarga le colonne
          Columns("D:D").EntireColumn.AutoFit 'allarga le colonne
          Columns("E:E").EntireColumn.AutoFit 'allarga le colonne
          Columns("F:F").EntireColumn.AutoFit 'allarga le colonne
          Columns("G:G").EntireColumn.AutoFit 'allarga le colonne
          Columns("H:H").EntireColumn.AutoFit 'allarga le colonne
          Selection.AutoFilter    ' inserisco il filtro per evidenziare solo i formulari
          ActiveSheet.Range("$A$1:$H$142").AutoFilter Field:=7, Criteria1:="<>"
          
          Set WB = ThisWorkbook
          With WB
           
              Set srcSH = .Sheets(sFoglioSorgente)
              Set destSH = .Sheets(sFoglioDestinazione)
              ur = destSH.Cells(destSH.Rows.Count, "A").End(xlUp).Row
          sPrimaCellaDestinazione = "A" & ur + 1
          
          End With
      
          With srcSH
         
              LRow = LastRow(srcSH, .Columns("A:A"))
              Set srcRng = .Range(sColonneDaCopiare)
             
          End With
      
          Set destRng = destSH.Range(sPrimaCellaDestinazione)
          On Error GoTo XIT
            With Application
              CalcMode = .Calculation
              .Calculation = xlCalculationManual
              .ScreenUpdating = False
          End With
          
          For Each rArea In srcRng.Areas
              Set Rng = rArea.Resize(LRow)
              Rng.Copy Destination:=destRng
              Set destRng = destRng.Offset(0, Rng.Columns.Count)
          
          Next rArea
      
      XIT:
          With Application
              .Calculation = CalcMode
              .ScreenUpdating = True
          End With
              
              Application.ScreenUpdating = False
              Worksheets("FirIngressi").Range("A1:ZZ10000").ClearContents 'elimina tutti i dati dsl foglio sorgente
              Worksheets("FirIngressi").Range("A1:ZZ10000").ClearContents 'elimina tutti i dati dsl foglio sorgente
              Worksheets("FirIngressi").Range("A1:ZZ10000").ClearFormats 'elimina tutti i dati dsl foglio sorgente
         
              Worksheets("CheckIN").Activate 'attiva il foglio "CheckIN"
            
          Call MsgBox( _
                   Prompt:="Formattazione e Copia Completata!", _
                   Buttons:=vbInformation, _
                   Title:="REPORT")  'fa apparire un messaggio sullo schermo
        
          Application.ScreenUpdating = True
          Set srcRng = Nothing
          Set Rng = Nothing
          Set destRng = Nothing
          Set WB = Nothing
      End Sub
      
      '--------->>
      Public Function LastRow(SH As Worksheet, _
                              Optional Rng As Range, _
                              Optional minRow As Long = 1)
                              Application.ScreenUpdating = False
          If Rng Is Nothing Then
              Set Rng = SH.Cells
          End If
      
          On Error Resume Next
          LastRow = Rng.Find(What:="*", _
                             After:=Rng.Cells(1), _
                             LookAt:=xlPart, _
                             LookIn:=xlFormulas, _
                             SearchOrder:=xlByRows, _
                             SearchDirection:=xlPrevious, _
                             MatchCase:=False).Row
          On Error GoTo 0
          If LastRow < minRow Then
              LastRow = minRow
          End If
          Set Rng = Nothing
          Application.ScreenUpdating = True
      End Function
      
      
      
      
      #30723 Score: 1 | Risposta

      Marius44
      Moderatore
        51 pts

        Ciao

        Se vuoi far "vedere" anche il file utilizza un sito appropriato per grossi file (per es. DropBox)

        Fai una prova: Lascia SOLO UNA VOLTA all'inizio della sub il codice  Application.ScreenUpdating = False e ripristinalo prima della chiusura della sub. Opera allo stesso modo per la Function.

        Tieni presente che l'istruzione non ti dà "lo schermo bianco" ma rimane ferma sulla schermata attiva quando inizia la macro.

        Altro discorso è "la clessidra": fai una ricerca in rete al titolo "CountDown"

         

        Ciao,

        Mario

        #30761 Score: 0 | Risposta

        mflauto
        Partecipante

          Grazie Mario 🙂

        Login Registrati
        Stai vedendo 3 articoli - dal 1 a 3 (di 3 totali)
        Rispondi a: funzione Application.ScreenUpdating che non funziona.
        Gli allegati sono permessi solo ad utenti REGISTRATI
        Le tue informazioni: