You are here:Home-Domande su Excel VBA e MACRO-[RISOLTO] Sostituzione dato su più fogli e relativo salvataggio-Rispondi a: [RISOLTO] Sostituzione dato su più fogli e relativo salvataggio
Rispondi a: [RISOLTO] Sostituzione dato su più fogli e relativo salvataggio2018-01-20T10:26:08+01:00

Home Forum Domande su Excel VBA e MACRO [RISOLTO] Sostituzione dato su più fogli e relativo salvataggio Rispondi a: [RISOLTO] Sostituzione dato su più fogli e relativo salvataggio

sidsid
Moderatore
    Post totali: 752

    Ciao…ti posto i codici aggiornati
    Mi raccomando devi fare molti test per verificare che non ci siano errori; mi sono costruito le directory con un pò di file pdf, ma non è mai come lavorare sul file originale; finché si tratta di sostituire stringhe è facile, ma lavorando poi con i link bisogna testarlo sul file originale.

    Questo il codice del pulsante sulla form; qui viene verificata l’esistenza del nuovo file in una delle 3 directory
    Attenzione: nei fogli devono esserci solo link

    Private Sub CommandButton1_Click()
    Dim sFogli As String, sNewFile As String
    Dim t As Date
    Dim bNonEsiste As Boolean
    
    t = Time
    If Not (Me.TextBox1.Value = vbNullString Or Me.TextBox2.Value = vbNullString) Then
        
        sNewFile = Me.TextBox2.Value & ".pdf"
        'verifico che il nuovo file esista in una delle 3 directory
        Select Case False
            Case Dir("C:\DATI\" & sNewFile, vbDirectory) = vbNullString
            Case Dir("C:\PARAMETRI\ALTEZZA\" & sNewFile, vbDirectory) = vbNullString
            Case Dir("C:\PARAMETRI\PESO\" & sNewFile, vbDirectory) = vbNullString
            Case Else
                bNonEsiste = True
        End Select
        
        If Not bNonEsiste Then
            Call SOSTITUISCI_CERTIFICATI(Me.TextBox1, Me.TextBox2, sFogli, sNewFile)
            If Not sFogli = vbNullString Then
                MsgBox "Ho Aggiornato i seguenti fogli:" & vbLf & sFogli & _
                vbLf & "CODICE ESEGUITO IN....." & Format(Time - t, "HH:MM:SS"), vbInformation, "AGGIORNAMENTO FOGLI"
                Unload Me
            Else
                MsgBox "Non ho trovato nessun parametro ''" & Me.TextBox1.Value & "''", vbExclamation, "ATTENZIONE"
            End If
        Else
            MsgBox "Il file sostitutivo ''" & Me.TextBox2.Value & ".pdf'' non esiste", vbExclamation, "ATTENZIONE"
        End If
    Else
        
    MsgBox "Entrambe le textbox devono essere popolate", vbExclamation, "ATTENZIONE"
    End If
    End Sub

    Questo invece la subroutine

    Sub SOSTITUISCI_CERTIFICATI(ByVal sCertificato1 As String, ByVal sCertificato2 As String, ByRef s As String, ByVal sNewFil As String)
    Dim wbNuovo As Workbook
    Dim ws As Worksheet
    Dim nRiga As Long
    Dim Area As Range, cl As Range
    Dim bEsiste As Boolean
    Dim sDir As String, sDir2 As String
    Application.ScreenUpdating = False
    
    'verifico l'esistenza della cartella principale (NOMINATIVI); nel caso la creo
    sDir = "C:\NOMINATIVI\"
    If Dir(sDir, vbDirectory) = "" Then
        MkDir (sDir)
    End If
    'ciclo tutti i fogli
    For Each ws In ThisWorkbook.Worksheets
        
        Select Case ws.Name
        
            Case "DATABASE", "CERTIFICATI", "CLIENTI"
            Case Else
                bEsiste = False
            
                'verifico l'esistenza della cartella foglio (es. ANNA); nel caso la creo
                sDir = "C:\NOMINATIVI\" & ws.Name & "\"
                If Dir(sDir, vbDirectory) = "" Then
                    MkDir (sDir)
                End If
            
                nRiga = ws.Range("A" & Rows.Count).End(xlUp).Row
                Set Area = ws.Range("A7:J" & nRiga)
                
                With Area
                    Set cl = .Find(sCertificato1, .Cells(.Rows.Count, .Columns.Count), , xlWhole)
                    If Not cl Is Nothing Then
                        bEsiste = True
                        
                        Do
                            'verifico se la cella ciclata è della colonna "B"
                            Select Case cl.Column
                                Case 2
                                    If Not Dir("C:\PARAMETRI\ALTEZZA\" & sNewFil, vbDirectory) = vbNullString Then
                                        sDir2 = "C:\PARAMETRI\ALTEZZA\" & sNewFil
                                    Else
                                        sDir2 = "C:\PARAMETRI\PESO\" & sNewFil
                                    End If
                                Case Else
                                    sDir2 = "C:\DATI\" & sNewFil
                            End Select
                            'aggiorno i link
                            With cl.Hyperlinks(1)
                                .Address = sDir2
                                .TextToDisplay = sCertificato2
                            End With
                            
                            'prossima cella
                            Set cl = .FindNext(cl)
                        Loop While Not cl Is Nothing
                        'On Error GoTo 0
                    End If
                End With
                If bEsiste Then
                    s = s & ws.Name & vbLf
                    ws.Copy
                    Set wbNuovo = ActiveWorkbook
                    Application.DisplayAlerts = False
                    wbNuovo.SaveAs sDir & "INDEX", FileFormat:=xlOpenXMLWorkbook
                    Application.DisplayAlerts = True
                    wbNuovo.Close True
            
                End If
        End Select
    Next ws
    
    Application.ScreenUpdating = True
    Set Area = Nothing
    Set cl = Nothing
    
    End Sub

    Fa sapere, ciao

    • Questa risposta è stata modificata 2 anni, 8 mesi fa da sidsid.