creare un foglio "master" o riepilogo" in automatico

Ciao vitaliano,

sono riuscito a scaricare il file.

ho sostituito la formula. funziona correttamente. 

Bene!

Lo scopo di questo era di cancellare le formule della riga se il collegamento fosse eliminato. Tuttavia, se questo ti fa fastidio, posso cancellare questo controllo.

Preferisco rinunciare al controllo e ridurre di 2 clic la procedura. nel caso in cui volessi cancellare le formule dell'intero rigo, procederò con l'eliminazione dell'intero rigo.

Prima di rispondere a questa richiesta, ti chiederei di verificare il codice nella mia ultima risposta.

===

Regards,

Norman

Ciao, Norman

sono riuscito a scaricare il file.

ho sostituito la formula. funziona correttamente.

Lo scopo di questo era di cancellare le formule della riga se il collegamento fosse eliminato. Tuttavia, se questo ti fa fastidioso, posso cancellare questo controllo.

Preferisco rinunciare al controllo e ridurre di 2 clic la procedura. nel caso in cui volessi cancellare le formule dell'intero rigo, procederò con l'eliminazione dell'intero rigo.

grazie ancora.

a presto

Ciao vitaliano,

...il collegamento ipertestuale, invece, forse è meglio continuare a lasciarlo "a mano", vero? non è remota la possibilità che i fogli cambino nome. In tal caso, adesso, correggo manualmente il collegamento ipertestuale. Se lo facciamo in VBA, bisognerebbe cambiare la programmazione, vero?

Per inserire i collegamenti della colonna A o aggionarli, prova qualcosa del genere:

• Alt-F11 per aprire l'editor di VBA
• Alt-IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

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

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim i As Long, j As Long, k As Long

    Dim LRow As Long

    Dim arrFile As Variant

    Dim sStr As String, aStr As String

    Dim sPath As String

    Dim CalcMode As Long

    Const sFile As String = "P-UNICA analisi "  

    Const sPercorso As String = "C:\Pippo" '<<===== Modifica

    Set WB = ThisWorkbook                                                               '<<===== Modifica

    Set SH = WB.Sheets("Riepilogo")                                                '<<===== Modifica

    With SH

        LRow = LastRow(SH, .Columns("A:A"))

        Set Rng = .Range("A1:N" & LRow)

        Rng.ClearContents

    End With

    With Application

        .EnableEvents = False

        Rng.ClearContents

        .EnableEvents = True

        aStr = .PathSeparator

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    If Right(sPercorso, 1) <> aStr Then

        sPath = sPercorso & aStr

    Else

        sPath = sPercorso

    End If

    ReDim arrFile(1 To 7)

    For i = 1 To 7

        arrFile(i) = sFile & i & ".xlsx"

    Next i

    For i = 1 To UBound(arrFile)

        Set WB = Workbooks.Open(sPath & arrFile(i))

        For j = 1 To WB.Worksheets.Count

            With WB.Sheets(j)

                sStr = "='[" & WB.Name & "]" & .Name & "'!" & "A1"

            End With

            If Evaluate(sStr) <> 0 Then

                k = k + 1

                With SH

                    SH.Cells(k + 1, 1).Formula = sStr

                End With

            End If

        Next j

        WB.Close Savechanges:=False

    Next i

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

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

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

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

• Alt-Q per chiudere l'editor di VBA e tornare a Excel.
• Alt-F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester | Esegui

Nota che l'aggiornamento dei collegamenti nella colonna A del foglio Riepilogo da questa procedura eseguirà il codice nel modulo di codice del foglio Riepilogo per aggiornare  automaticamente le formule nelle colonne B: M.

Per escludere i grafici e facilitare lo scaricamento del mio file di prova, ho cancellato tutti i fogli, tranne per il foglio Riepilogo. Potresti scaricare il file Vitaliano#3_20150521.xlsm a:                                                                              **http://1drv.ms/1KnjFmc**

===

Regards,

Norman

Ciao vitaliano,

non sono riuscito a scaricare il file

Io non potevo replicare questo! Per me bastava fare clic dx sull'icona del file e selezionare l'opzione Scarica.

, ma ho copiato l'intero procedimento, seguendo le Tue disposizioni. funziona!!

quando inserisco un nuovo rigo, mi compare una prima finestra di errore: "La cella A... non contiene un comando valido. vuoi continuare?" rispondo di "si"; ne compare un'altra: "vuoi cancellare le celle? B...:K..."; rispondo di "no"; creo un collegamento valido in A, ed il gioco è fatto!!

Lo scopo di questo era di cancellare le formule della riga se il collegamento fosse eliminato. Tuttavia, se questo ti fa fastidio, posso cancellare questo controllo.

mi resta da trascinare "a mano" le formule in M e in N. se è possibile inserire nel procedimento anche questo passaggio, bene. Altrimenti, va bene lo stesso.

Sostituisci il codice nel modolo di codice del foglio Riepilogo con la seguente versione:

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

Option Explicit

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

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Rng As Range, Rng2 As Range, rCell As Range

    Dim sStr As String

    Dim i As Long

    Dim Res As VbMsgBoxResult

    Dim CalcMode As Long

    If Target.Row = 1 Then

        Exit Sub

    End If

    Set Rng = Intersect(Me.Range("A:A"), Target)

    If Not Rng Is Nothing Then

        On Error GoTo XIT

        With Application

            CalcMode = .Calculation

            .Calculation = xlCalculationManual

            .EnableEvents = False

            .ScreenUpdating = False

        End With

        For Each rCell In Rng.Cells

            With rCell

                On Error Resume Next

                sStr = Split(.Formula, "!")(0)

                If Err.Number = 0 Then

                    rCell.Offset(0, 1).Formula = sStr & "!" & "H10"

                    For i = 2 To 11

                        rCell.Offset(0, i).Formula = sStr & "!" & "I" & i - 1

                    Next i

                    .Offset(0, 12).FormulaR1C1 = "=SUM(RC[-9]:RC[-4])+RC[-2]"

                    .Offset(0, 13).FormulaR1C1 = "=RC[-1]-RC[-2]"

                Else

                    Err.Clear

                    Select Case MsgBox("La cella " _

                                     & rCell.Address(0, 0) _

                                     & " non comprende un collegmento valido!" _

                                     & vbNewLine & vbNewLine _

                                     & "Vuoi continuare?", _

                                       Buttons:=vbYesNo Or vbExclamation Or vbDefaultButton1, _

                                       Title:="CONTROLLA COLLEGAMENTO")

                    Case vbNo

                        Application.Undo

                        GoTo XIT

                    Case vbYes

                        Set Rng2 = rCell.Offset(0, 1).Resize(1, 10)

                        Res = MsgBox(Prompt:="Vuoi cancellare le celle? " _

                                           & Rng2.Address(0, 0), _

                                     Buttons:=vbYesNo, _

                                     Title:="CANCELLARE FORMULE?")

                        If Res = vbYes Then

                            Rng2.ClearContents

                        End If

                    End Select

                End If

            End With

        Next rCell

    End If

XIT:

    With Application

        .Calculation = CalcMode

        .EnableEvents = True

        .ScreenUpdating = True

    End With

End Sub

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

Potresti scaricare il file aggiornato ~~Vitaliano20150521.xlsm~~a: **http://1drv.ms/1BdXtCG**

[Edit]

Ho tolto i fogli grafici, lasciando solo il foglio **Riepilogo,**e ho caricato il nuovo file Vitaliano20150521.xlsm a **http://1drv.ms/1INrmlf**

===

Regards,

Norman