Macro per popolare un foglio Excel con dati presi da altro foglio, a determinate condizioni

Question

Macro per popolare un foglio Excel con dati presi da altro foglio, a determinate condizioni

Anonimo

Buongiorno a tutti,

vorrei creare una macro per copiare determinate celle (indirizzi email) di un foglio di una cartella di lavoro Excel, per cui si verifica una condizione in una cella della medesima riga (ATTIVA, IN SCADENZA, SCADUTA), in un determinato foglio di un'altra cartella di lavoro.

Foglio di origine:

EMAIL CLIENTE	STATO MANUTENZIONE
******@libero.it	ATTIVA

******@yahoo.com	IN SCADENZA

Foglio di destinazione (Clienti Manutenzione Attiva):

EMAIL
******@libero.it

Fatto questo, vorrei poter creare, in una cella del nuovo foglio, una concatenazione di questi indirizzi email intervallati da un ";"

Ringrazio in anticipo la buona anima che verrà, mi auguro, in mio aiuto

Luca

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

3 risposte

Answer 1

Ciao Luca,

Per rendere il mio codice più robusto e resiliente e per eliminare uno specifico bug minore, prova a sostituire il mio codice con la seguente versione:

'========>>

Option Explicit

Option Compare Text

'-------->>

Public Sub Tester()

Dim WB As Workbook 

Dim srcSH As Worksheet, SH\_Attiva As Worksheet, SH\_Scaduta As Worksheet, SH\_InScadenza As Worksheet 

Dim srcRng As Range, destRng As Range 

Dim arrIn As Variant, arrAttiva() As Variant, arrScaduta() As Variant, arrInScadenza() As Variant 

Dim sStr As String 

Dim i As Long, j As Long 

Dim iRow As Long, jRow As Long, kRow As Long 

Dim iCtr As Long, jCtr As Long, kCtr As Long 

Const sFoglio\_Sorgente As String = **"Foglio1"                          '&lt;&lt;=== Modifica** 

Const sFoglio\_Attiva As String = **"Attiva"                                  '&lt;&lt;=== Modifica** 

Const sFoglio\_Scaduta As String = **"Scaduta"                           '&lt;&lt;=== Modifica** 

Const sFoglio\_InScadenza As String = **"In Scadenza"               '&lt;&lt;=== Modifica** 

Set WB = ThisWorkbook 

With WB 

    Set srcSH = .Sheets(sFoglio\_Sorgente) 

    If SheetExists(sFoglio\_Attiva) Then 

        Set SH\_Attiva = .Sheets(sFoglio\_Attiva) 

    Else 

        Set SH\_Attiva = .Sheets.Add 

        SH\_Attiva.Name = sFoglio\_Attiva 

    End If 

    If SheetExists(sFoglio\_Scaduta) Then 

        Set SH\_Scaduta = .Sheets(sFoglio\_Scaduta) 

    Else 

        Set SH\_Scaduta = .Sheets.Add 

        SH\_Scaduta.Name = sFoglio\_Scaduta 

    End If 

    If SheetExists(sFoglio\_InScadenza) Then 

        Set SH\_InScadenza = .Sheets(sFoglio\_InScadenza) 

    Else 

        Set SH\_InScadenza = .Sheets.Add 

        SH\_InScadenza.Name = sFoglio\_InScadenza 

    End If 

End With 

With srcSH 

    iRow = LastRow(srcSH, .Columns("A")) 

    Set srcRng = .Range("A1").Resize(iRow, 2) 

End With 

arrIn = srcRng.Value 

ReDim arrAttiva(1 To UBound(arrIn)) 

ReDim arrScaduta(1 To UBound(arrIn)) 

ReDim arrInScadenza(1 To UBound(arrIn)) 

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

    Select Case arrIn(i, 2) 

        Case "Attiva" 

            sStr = arrIn(i, 1) 

            If IsValidEmail(sStr) Then 

                iCtr = iCtr + 1 

                arrAttiva(iCtr) = sStr 

            End If 

        Case "Scaduta" 

        sStr = arrIn(i, 1) 

            If IsValidEmail(sStr) Then 

                jCtr = jCtr + 1 

                arrScaduta(jCtr) = sStr 

            End If 

        Case "In Scadenza" 

        sStr = arrIn(i, 1) 

            If IsValidEmail(sStr) Then 

                kCtr = kCtr + 1 

                arrInScadenza(kCtr) = sStr 

            End If 

    End Select 

Next i 

With SH\_Attiva 

    jRow = LastRow(SH\_Attiva, .Columns("A")) 

    kRow = LastRow(SH\_Attiva, .Columns("C"), jRow + 1) 

    ReDim Preserve arrAttiva(1 To iCtr) 

    .Range("A" & jRow + 1).Resize(iCtr).Value = Application.Transpose(arrAttiva) 

    .Range("C" & kRow).Value = Join(arrAttiva, ", ") 

    .UsedRange.EntireColumn.AutoFit 

End With 

With SH\_Scaduta 

    jRow = LastRow(SH\_Scaduta, .Columns("A")) 

    kRow = LastRow(SH\_Scaduta, .Columns("C"), jRow + 1) 

    ReDim Preserve arrScaduta(1 To jCtr) 

    .Range("A" & jRow + 1).Resize(jCtr).Value = Application.Transpose(arrScaduta) 

     .Range("C" & kRow).Value = Join(arrScaduta, ", ") 

    .UsedRange.EntireColumn.AutoFit 

End With 

With SH\_InScadenza 

    jRow = LastRow(SH\_InScadenza, .Columns("A")) 

    kRow = LastRow(SH\_InScadenza, .Columns("C"), jRow + 1) 

    ReDim Preserve arrInScadenza(1 To kCtr) 

    .Range("A" & jRow + 1).Resize(kCtr).Value = Application.Transpose(arrInScadenza) 

    .Range("C" & kRow).Value = Join(arrInScadenza, ", ") 

    .UsedRange.EntireColumn.AutoFit 

End With 

Call MsgBox(Prompt:="Fatto", Buttons:=vbInformation, Title:="REPORT")

End Sub

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

Public Function SheetExists(sSheetName As String, _

Optional ByVal WB As Workbook) As Boolean 

On Error Resume Next 

If WB Is Nothing Then 

    Set WB = ThisWorkbook 

End If 

SheetExists = CBool(Len(WB.Sheets(sSheetName).Name))

End Function

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

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, \_ 

Optional minRow As Long = 1) 

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 &lt; minRow Then 

    LastRow = minRow 

End If

End Function

'-------->>

Public Function IsValidEmail(sEmailAddress As String) As Boolean

Dim sEmailPattern As String 

Dim oRegEx As Object 

Dim bReturn As Boolean 

sEmailPattern = "^([a-zA-Z0-9\_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)\*(\.[a-z]{2,3})$" 

Set oRegEx = CreateObject("VBScript.RegExp") 

oRegEx.Global = True 

oRegEx.IgnoreCase = True 

oRegEx.Pattern = sEmailPattern 

bReturn = False 

If oRegEx.Test(sEmailAddress) Then 

    If oRegEx.Test(sEmailAddress) Then 

        bReturn = True 

    End If 

Else 

    bReturn = False 

End If 

IsValidEmail = bReturn

End Function

'<<========

Ho aggiornato il mio file di prova Luca20230210.xlsm

===

Regards,

Norman

Answer 2

Ciao Luca,

Buongiorno a tutti,

vorrei creare una macro per copiare determinate celle (indirizzi email) di un foglio di una cartella di lavoro Excel, per cui si verifica una condizione in una cella della medesima riga (ATTIVA, IN SCADENZA, SCADUTA), in un determinato foglio di un'altra cartella di lavoro.

Foglio di origine:

EMAIL CLIENTE STATO MANUTENZIONE

*** L'indirizzo e-mail viene rimosso per motivi di privacy *** ATTIVA

*** L'indirizzo e-mail viene rimosso per motivi di privacy *** IN SCADENZA

Foglio di destinazione (Clienti Manutenzione Attiva):

EMAIL

*** L'indirizzo e-mail viene rimosso per motivi di privacy ***

Fatto questo, vorrei poter creare, in una cella del nuovo foglio, una concatenazione di questi indirizzi email intervallati da un ";"

Ringrazio in anticipo la buona anima che verrà, mi auguro, in mio aiuto

Luca

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

Option Compare Text

'-------->>

Public Sub Tester()

Dim WB As Workbook 

Dim srcSH As Worksheet, SH\_Attiva As Worksheet, SH\_Scaduta As Worksheet, SH\_InScadenza As Worksheet 

Dim srcRng As Range, destRng As Range 

Dim arrIn As Variant, arrAttiva() As Variant, arrScaduta() As Variant, arrInScadenza() As Variant 

Dim i As Long, j As Long 

Dim iRow As Long, jRow As Long 

Dim iCtr As Long, jCtr As Long, kCtr As Long 

Const sFoglio\_Sorgente As String = "Foglio1"                      '&lt;&lt;=== Modifica 

Const sFoglio\_Attiva As String = "Attiva"                         '&lt;&lt;=== Modifica 

Const sFoglio\_Scaduta As String = "Scaduta"                       '&lt;&lt;=== Modifica 

Const sFoglio\_InScadenza As String = "In Scadenza"                '&lt;&lt;=== Modifica 

Set WB = ThisWorkbook 

With WB 

    Set srcSH = .Sheets(sFoglio\_Sorgente) 

    If SheetExists(sFoglio\_Attiva) Then 

        Set SH\_Attiva = .Sheets(sFoglio\_Attiva) 

    Else 

        Set SH\_Attiva = .Sheets.Add 

        SH\_Attiva.Name = sFoglio\_Attiva 

    End If 

    If SheetExists(sFoglio\_Scaduta) Then 

        Set SH\_Scaduta = .Sheets(sFoglio\_Scaduta) 

    Else 

        Set SH\_Scaduta = .Sheets.Add 

        SH\_Scaduta.Name = sFoglio\_Scaduta 

    End If 

    If SheetExists(sFoglio\_InScadenza) Then 

        Set SH\_InScadenza = .Sheets(sFoglio\_InScadenza) 

    Else 

        Set SH\_InScadenza = .Sheets.Add 

        SH\_InScadenza.Name = sFoglio\_InScadenza 

    End If 

End With 

With srcSH 

    iRow = LastRow(srcSH, .Columns("A")) 

    Set srcRng = .Range("A1").Resize(iRow, 2) 

End With 

arrIn = srcRng.Value 

ReDim arrAttiva(1 To UBound(arrIn)) 

ReDim arrScaduta(1 To UBound(arrIn)) 

ReDim arrInScadenza(1 To UBound(arrIn)) 

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

    Select Case arrIn(i, 2) 

        Case "Attiva" 

            iCtr = iCtr + 1 

            arrAttiva(iCtr) = arrIn(i, 1) 

        Case "Scaduta" 

            jCtr = jCtr + 1 

            arrScaduta(jCtr) = arrIn(i, 1) 

        Case "In Scadenza" 

            kCtr = kCtr + 1 

            arrInScadenza(kCtr) = arrIn(i, 1) 

    End Select 

Next i 

'    ReDim Preserve arrAttiva(1 To iCtr) 

With SH\_Attiva 

    jRow = LastRow(SH\_Attiva, .Columns("A")) 

    ReDim Preserve arrAttiva(1 To iCtr) 

    .Range("A" & jRow + 1).Resize(iCtr).Value = Application.Transpose(arrAttiva) 

    .Range("C2").Value = Join(arrAttiva, ", ") 

      .UsedRange.EntireColumn.AutoFit 

End With 

With SH\_Scaduta 

    jRow = LastRow(SH\_Scaduta, .Columns("A")) 

     ReDim Preserve arrScaduta(1 To jCtr) 

    .Range("A" & jRow + 1).Resize(jCtr).Value = Application.Transpose(arrScaduta) 

    .Range("C2").Value = Join(arrScaduta, ", ") 

    .UsedRange.EntireColumn.AutoFit

End With

With SH\_InScadenza 

    jRow = LastRow(SH\_InScadenza, .Columns("A")) 

     ReDim Preserve arrInScadenza(1 To kCtr) 

    .Range("A" & jRow + 1).Resize(kCtr).Value = Application.Transpose(arrInScadenza) 

    .Range("C2").Value = Join(arrInScadenza, ", ") 

      .UsedRange.EntireColumn.AutoFit 

End With 

Call MsgBox(Prompt:="Fatto", Buttons:=vbInformation, Title:="REPORT")

End Sub

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

Public Function SheetExists(sSheetName As String, _

Optional ByVal WB As Workbook) As Boolean 

On Error Resume Next 

If WB Is Nothing Then 

    Set WB = ThisWorkbook 

End If 

SheetExists = CBool(Len(WB.Sheets(sSheetName).Name))

End Function

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

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, \_ 

Optional minRow As Long = 1) 

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 &lt; minRow Then 

    LastRow = minRow 

End If

End Function

'<<========

Alt+Q per chiudere l'editor di VBA e tornare a Excel.
Salva il file con l'estensione xlsm
Alt+F8 per aprire la finestra di gestione delle macro
Seleziona Tester
Esegui

Potresti scaricare il mio file di prova Luca20230210.xlsm

A causa di un problema con l'attuale editor del forum, che inserisce righe vuote indesiderate nel codice copiato dal forum, suggerirei di copiare il mio codice direttamente dal mio file di prova.

===

Regards,

Norman

Answer 3

Ciao Luca

Sono AnnaThomas e sarei felice di aiutarti con la tua domanda. In questo forum, siamo consumatori Microsoft proprio come te.

Ecco un esempio del codice che puoi usare:

Sub CopyEmails() Dim wb1 come cartella di lavoro Dim wb2 come cartella di lavoro Dim sht1 come foglio di lavoro Dim sht2 come foglio di lavoro Dim lastRow As Long Dim email come stringa

Set wb1 = Workbooks.Open("C:\Path\To\Source\Workbook.xlsx") Set wb2 = ThisWorkbook Impostare sht1 = wb1. Fogli ("STATO DI MANUTENZIONE E-MAIL CLIENTE") Impostare sht2 = wb2. Fogli ("Clienti di manutenzione attiva")

lastRow = sht1. Celle(sht1. Rows.Count, "A"). Fine(xlUp). Fila

Per i = 1 All'ultima riga Se sht1. Cellule(i, 3). Valore = "ATTIVO" Allora email = sht1. Cellule(i, 2). Valore SHT2. Celle(sht2. Rows.Count, "A"). Fine(xlUp). Offset (1; 0). Valore = email Fine Se Avanti i

email = "" lastRow = sht2. Celle(sht2. Rows.Count, "A"). Fine(xlUp). Fila

Per i = 1 All'ultima riga email = email & sht2. Cellule(i, 1). Valore & ";" Avanti i

SHT2. Celle(lastRow + 1, 1). Valore = email

WB1. Chiudi False Fine sub

In questa macro si presuppone che la cartella di lavoro di origine si trovi in C:\Path\To\Source\Workbook.xlsx.

Si noti che questo codice è solo un esempio e potrebbe essere necessario modificare per soddisfare le proprie esigenze specifiche.

Spero che questo aiuti ;-), fammi sapere se questo è contrario a ciò di cui hai bisogno, sarei comunque utile per rispondere a più delle tue domande.

Migliori saluti

AnnaThomas

Restituisci alla comunità. Aiuta la persona successiva con questo problema indicando se questa risposta ha risolto il tuo problema. Fare clic su Sì o No nella parte inferiore.

Questa risposta è stata tradotta automaticamente. Di conseguenza, potrebbero esserci errori grammaticali o espressioni strane.

Condividi tramite

Macro per popolare un foglio Excel con dati presi da altro foglio, a determinate condizioni

3 risposte