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-15T19:55:59+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

    Prova questa possibile soluzione:

    quasto codice lo abbini all’evento click del pulsante sul form

    Private Sub CommandButton1_Click()
    Dim sFogli As String
    
    If Not (Me.TextBox1.Value = vbNullString Or Me.TextBox2.Value = vbNullString) Then
    Call SOSTITUISCI_CERTIFICATI(Me.TextBox1, Me.TextBox2, sFogli)
    If Not sFogli = vbNullString Then
    MsgBox "Ho Aggiornato i seguenti fogli:" & vbLf & sFogli, vbInformation, "AGGIORNAMENTO FOGLI"
    Unload Me
    Else
    MsgBox "Non ho trovato nessun parametro ''" & Me.TextBox1.Value & "''", vbExclamation, "ATTENZIONE"
    End If
    Else
    MsgBox "Entrambe le textbox devono essere popolate", vbExclamation, "ATTENZIONE"
    End If
    End Sub

    Questo invece in un modulo standard

    Sub SOSTITUISCI_CERTIFICATI(ByVal sCertificato1 As String, ByVal sCertificato2 As String, ByRef s 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
    
    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
    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
    On Error Resume Next
    Do
    cl.Value = sCertificato2
    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
    Next ws
    Application.ScreenUpdating = True
    Set Area = Nothing
    Set cl = Nothing
    End Sub

    Fammi sapere se è abbastanza veloce, visto che hai un centinaio di fogli; se non lo fosse proviamo ad impostare la macro con le matrici