copia range dati fisso su altro foglio con range destinazione variabile

Ciao Nixio,

sto provando il tuo codice con soddisfazione e facendo diverse prove.

Come Ti dicevo la tabella origine viene compilata lanciando altre macro che pescano dati un po ovunque quindi la creazione della tabella dura circa 15-20 secondi... poi c'è la tua routine che copia ed incolla questa tabella nel foglio2... insomma prima del msgbox "Fine" passa un po di tempo...

mi piacerebbe che all'inizio dell'elaborazione venga visualizzato un messaggio di attesa del tipo "La copia dei dati è in corso.... Attendere". messaggio che scompare alla fine con l'avviso "Copia Terminata!".

Mentre io credo che sia buona norma informare l'utente dello stato di avanzamento del codice, la mia prima considerazione sarebbe quello di ridurre il tempo di esecuzione, per quanto possibile. In questo modo si aumenterà l'efficienza e si  ridurrà la frustrazione dell'utente. Non ho visto la maggior parte del tuo codice, ma, sulla base del codice che hai postato nel tuo ultimo post, ti consiglierei, per quanto possibile, di evitare le selezioni di oggetti come, ad esempio, fogli o intervalli: tali selezioni sono molto raramente necessarie, sono molto inefficienti e hanno un effetto deleterio sul tempo di esecuzione di codice. In generale, credo sia di gran lunga preferibile assegnare gli oggetti di interesse a variabili oggetto e quindi utilizzare queste variabili per eseguire le azioni necessarie in memoria. Vorrei anche consigliarti di ridurre al minimo le operazioni di lettura/scrittura; queste operazioni richiedono ingenti risorse e posono avere un notevole effetto negativo sui tempi di esecuzione di codice. Una tecnica per evitare operazioni ripetute di lettura/scrittura è di passare i dati contenuti in un intervallo ad un'array, elaborare i dati come richiesto e, successivamente, copiare i dati modificati dall'array al foglio di Excel.

Al questo riguardo, tornando dal generale ad un piccolo esempio  specifico, io sostituirei

Worksheets("Dettaglio_").Select

     Range("c9:s9").Select

     Range(Selection, Selection.End(xlDown)).Select

     Selection.Clear

con qualcosa del genere:

    Set SH = ThisWorkbook.Sheets(""Dettaglio_")

    Set Rng = SH.Range("C9:S9")

    SH.Range(Rng, Rng.End(xlDown)).ClearContents

Ti prego di considerare ciò, non come qualsiasi forma di critica ma invece, nel vero senso in cui lo intendevo, come consigli amichevoli.

Tornando alla tua preoccupazione principale, cioè il messaggio di attesa:

Ho letto un po in giro e il suggerimento è usare una form che esegue il codice per far apparire il messaggio.

Ho provato ma il messaggio non viene mostrato durante tutta l'elaborazione.

Riporto qui parte del codice:

Option Explicit

Dim dbConnection As ADODB.Connection

Sub export_tabl()

Application.ScreenUpdating = False

Worksheets("Dettaglio_").Select

     Range("c9:s9").Select

     Range(Selection, Selection.End(xlDown)).Select

     Selection.Clear

Call ShowPleaseWait

If (ThisWorkbook.Sheets("foglio3").Range("I12") = "si") Then

    Call B_caso1

    If (ThisWorkbook.Sheets("foglio3").Range("G13") = "si") Then

        Call caso1_1

        Call dettaglio_tbl ' questa crea la tabella origine

        Call copia_dettaglio 'questa è la sub che hai creato tu

    End If

'continuano altre condizioni e se verificate viene generata una nuova tabella, quindi copiata ecc ecc

'Chiudo cosi:

    Application.Goto ThisWorkbook.Sheets("Dettaglio_KPI").Range("A1")

    Application.ScreenUpdating = True

    Call KillPleaseWait

 end sub

il codice

Sub ShowPleaseWait()
    With ActiveSheet
        KillPleaseWait
         'call  delete routine
        .Shapes.AddShape(msoShapeRectangle, 0.75, 0.75, 100, 50).Name = "Wait" 'crea rettangolo
        With .Shapes("Wait")
            .TextFrame.Characters.Text = "Please Wait...."'Scritta 
            .Fill.ForeColor.SchemeColor = 13'colore sfondo
        End With
        ActiveCell.Activate
    End With
End Sub
 
Sub KillPleaseWait()
    On Error Resume Next
     'in  case its not there
    ActiveSheet.Shapes("Wait").Delete
End Sub

Sub Prova()
Dim I As Long

'Mette scritta
Call ShowPleaseWait

'esegue la macro
For I = 0 To 100000000

Next I
End Sub
Sub Prova1()
'Mette scritta
Call ShowPleaseWait

'esegue macro
Call Prova
'toglie scritta
Call KillPleaseWait

End SubSono sbagliati i punti in cui è inserito il codice?

Ho provato la tua procedura export_tabl, leggermente rivista per superare il problema del codice mancante e nomi dei fogli sconosciuti, e sono stato in grado di vedere il messaggio di attesa continuamente fino a quando il codice aveva completato il suo lavoro.

Ho quindi provato le tue due procedure di prova, Prova1 e Prova: anche in questo caso il messaggio di attesa è stato chiaramente e costantemente visibile finché l'esecuzione del codice fosse stata correttamente terminata.

A proposito, anche se ciò non influisce il problema di fondo, in modo da vedere e leggere il messaggio di attesa più facilmente, ho sostituito

.Fill.ForeColor.SchemeColor = 1 3

con:

            .Fill.ForeColor.SchemeColor = 4

Per motivi di completezza, la versione del tuo codice di prova che ho utilizzato per i miei test era:

'=========>>

Public Sub Prova1()

    Dim dStart As Double

    dStart = Timer

    Call ShowPleaseWait

    Call Prova

    Call KillPleaseWait

    MsgBox "Elapsed time: " & Timer - dStart

End Sub

'--------->>

Public Sub Prova()

    Dim i As Long

    Call ShowPleaseWait

    With ActiveSheet.Shapes("Wait").TextFrame.Characters

        For i = 1 To 10 ^ 8

            If i Mod (10 ^ 5) = 0 Then

              DoEvents

                .Text = "Please Wait...." & vbNewLine & i

            End If

        Next i

    End With

End Sub

'--------->>

Public Sub ShowPleaseWait()

    With ActiveSheet

        KillPleaseWait

        .Shapes.AddShape(msoShapeRectangle, 0.75, 0.75, 100, 50) _

                                                .Name = "Wait"

        With .Shapes("Wait")

            .TextFrame.Characters.Text = "Please Wait...."

            .Fill.ForeColor.SchemeColor = 4

        End With

        ActiveCell.Activate

    End With

End Sub

'--------->>

Public Sub KillPleaseWait()

    On Error Resume Next

    ActiveSheet.Shapes("Wait").Delete

    On Error GoTo 0

End Sub

'<<=========

Se, impiegando una procedura di test analoga, ed escludendo altro codice, non riesci a visualizzare il messaggio di attesa, credo che ci possa essere un problema fondamentale. Se, però, eseguendo il codice di prova, si visualizza correttamente il messaggio, ma non riesci a visualizzarlo  quando  esegui quel altro codice, penso che non sia irragionevole sospettare che l'altro codice, o forse la sua implentazione, sia incriminato. Tuttavia, senza ulteriori informazioni non vorrei essere categorico.

===

Regards,

Norman

Ciao Nixio,

Come hai notato, il problema che avevi riscontrato  era dovuta alla presenza di celle unite. Purtroppo, nella mia esperienza, celle unite sono sempre molto problematiche, sia con VBA che in Excel..

Con il vantaggio di vedere la struttura dei dati, ho adattato il codice per affrontare le celle unite e sono anche stato in grado di semplificare il mio codice suggerito.

Pertanto, prova a sostituire il codice precedente con la seguente versione:

'=========>>

Option Explicit

'--------->>

Public Sub copia_dettaglio()

    Dim WB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range, destRng2 As Range

    Dim rngCondizione As Range

    Dim copyRng As Range

    Dim rArea As Range

    Dim condizione1 As String, condizione2 As String

    Dim condizione3 As String

    Dim i As Long, j As Long

    Dim iRow As Long, jRow As Long

    Dim iFirstCol As Long

    Const sSourceRange As String = "D77:V96"      '<<=== Modifica

    Const sDestColonne As String = "E:R"               '<<=== Modifica

    Const sFoglioFonte As String = "Foglio1"          '<<=== Modifica

    Const sFoglioDest As String = "Foglio2"           '<<=== Modifica

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets(sFoglioFonte)

        Set destSH = .Sheets(sFoglioDest)

    End With

    With srcSH

        Set srcRng = srcSH.Range(sSourceRange)

        iRow = LastRow(srcSH, srcRng)

        j = srcRng.Rows.Count

    End With

    With destSH

        Set destRng = .Columns(sDestColonne)

        iFirstCol = destRng.Columns(2).Column

        jRow = LastRow(destSH, .Columns(sDestColonne))

        Set destRng2 = .Cells(jRow + 2, iFirstCol)

    End With

    srcRng.Columns(1).Copy Destination:=destRng2

    Set copyRng = Intersect(srcRng, srcSH.Columns("K:V"))

    copyRng.Copy Destination:=destRng2.Offset(0, 1)

    Set rngCondizione = destRng2.Offset(0, -3).Resize(j, 3)

    On Error GoTo XIT

    Application.ScreenUpdating = False

    With srcSH

        condizione1 = .Range("B4").Value

        condizione2 = .Range("F4").Value

        condizione3 = .Range("J4").Value

    End With

    With rngCondizione

        .RowHeight = 27

        .Font.Bold = True

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

        .Value = VBA.Array(condizione1, condizione2, condizione3)

    End With

    Call AddBorders(rngCondizione)

    Call MsgBox(Prompt:="Finito", _

                Buttons:=vbInformation, _

                Title:="MACRO ESEGUITA!")

XIT:

    Application.ScreenUpdating = True

End Sub

'--------->>

Public Function AddBorders(aRng As Range)

    Dim ArrBorders As Variant

    Dim i As Long

    With aRng

        ArrBorders = Array(.Borders(xlEdgeLeft), _

                           .Borders(xlEdgeTop), _

                           .Borders(xlEdgeBottom), _

                           .Borders(xlEdgeRight), _

                           .Borders(xlInsideVertical), _

                           .Borders(xlInsideHorizontal))

        For i = LBound(ArrBorders) To UBound(ArrBorders)

            With ArrBorders(i)

                .LineStyle = xlContinuous

                .Weight = xlMedium

                .ColorIndex = xlAutomatic

            End With

        Next i

    End With

End Function

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range)

    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

End Function

'<<=========

Ho testato il codice eseguendo il codice con cinque Tabelle successive. Potresti  vedere i risultati nel mio file di prova Nixio # _20150704.xlsm che ho caricato su Microsoft OneDrive a:                                                                    http://1drv.ms/1GWkRXR

Nota: Questo post è una ripetizione perché ho inavvertitamente cancellato la mia risposta precedente!

===

Regards,

Norman