› Sviluppare funzionalita su Microsoft Office con VBA › funzione Application.ScreenUpdating che non funziona.
-
AutoreArticoli
-
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
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
-
AutoreArticoli