Macro excel per compilare campi filtrati

Question

Salve,

ho una tabella (n° righe variabile, n° colonne fisso pari a 45) nella quale filtro i dati presenti in colonna J in base al criterio "termina con" "LAN" e fin qui la macro funziona; poi devo inserire in colonna F nelle celle filtrate il valore di testo "CD" e qui la macro non funziona.

Devo poi proseguire filtrando sempre in colonna J i dati in tabella secondo il criterio "non termina con" "LAN" e di nuovo tornare in colonna F e riempire i campi con "DVD". Quindi togliere i filtri e visualizzare l'intera tabella.

Answer 1

Ciao Guandrake,

volendo utilizzare un approcio differente, senza la necessità di filtrare i dati della tabella si potrebbe pensare ad una macro come quella di questo file di esempio:

File esempio: File Esempio #3

Questa la macro, che utilizza alcune delle variabili nominate come nella precedente, che elabora i dati dopo che gli stessi sono memorizzati in una matrice andando a modifivare i valori presenti nella matrice per poi riportare la stessa matrice dati nella medesima posizione originaria.

'---

Option Explicit

Sub ElaboraTabellaDati()

  Const sNomeFoglioTabella As String = "Foglio1"

  Const sPrimaCellaTabella As String = "A1"

  Const sColonnaCriterio As String = "J"

  Const sColonnaTesto As String = "F"

  Const sColonnaDaCopiare As String = "O"

  Const sColonnaInCuiIncollare As String = "R"

  Const sCriterio As String = "LAN"

  Dim Twb As Workbook

  Dim WsTabella As Worksheet

  Dim rTabellaDati As Range

  Dim NumeroRecord As Long

  Dim arrDati() As Variant

  Dim iPrimaColonna As Long

  Dim iColCriterio As Long

  Dim iColTesto As Long

  Dim iColDaCopiare As Long

  Dim iColInCuiIncollare As Long

  Dim valCriterio As String

  Dim i As Long

  On Error GoTo Errore

  Set Twb = ThisWorkbook

  Set WsTabella = Twb.Worksheets(sNomeFoglioTabella)

  With WsTabella

    With .Range(sPrimaCellaTabella)

      With .CurrentRegion

        NumeroRecord = .Rows.Count - 1

        If NumeroRecord = 0 Then Exit Sub

        Set rTabellaDati = .Offset(1).Resize(NumeroRecord)

        arrDati = rTabellaDati.Value

        'arrDati = rTabellaDati.Formula

      End With

      iPrimaColonna = .Columns(1).Column

    End With

    iColCriterio = .Columns(sColonnaCriterio).Column - iPrimaColonna + 1

    iColTesto = .Columns(sColonnaTesto).Column - iPrimaColonna + 1

    iColDaCopiare = .Columns(sColonnaDaCopiare).Column - iPrimaColonna + 1

    iColInCuiIncollare = .Columns(sColonnaInCuiIncollare).Column - iPrimaColonna + 1

  End With 'WsTabella

  For i = 1 To NumeroRecord

    valCriterio = UCase(Right(arrDati(i, iColCriterio), Len(sCriterio)))

    Select Case valCriterio

      Case sCriterio

        arrDati(i, iColTesto) = "CD"

        arrDati(i, iColInCuiIncollare) = arrDati(i, iColDaCopiare)

        arrDati(i, iColDaCopiare) = Empty

      Case Is <> sCriterio

        arrDati(i, iColTesto) = "DVD"

    End Select

  Next i

  With Application

    .Calculation = xlCalculationManual

    .ScreenUpdating = False

    .EnableEvents = False

  End With

  rTabellaDati.Value = arrDati

  'rTabellaDati.Formula = arrDati

  MsgBox "Elaborazione terminata.", vbInformation, "ElaboraTabellaDati"

RiprendiErrore:

  With Application

    .Calculation = xlCalculationAutomatic

    .ScreenUpdating = True

    .EnableEvents = True

  End With

  Exit Sub

Errore:

  MsgBox "Errore n. " & Err.Number & vbNewLine & _

         Err.Description, vbCritical, "Errore VBA"

  Resume RiprendiErrore

End Sub

'---

Nota che se nella tua tabella fossero presenti delle formule da preservare potresti sostituire

        arrDati = rTabellaDati.Value

con

        'arrDati = rTabellaDati.Formula

e

        rTabellaDati.Value = arrDati

con

    'rTabellaDati.Formula = arrDati

dove adesso sono attive le righe dove vengono utilizzati i valori e non le "formule"

A mio parere questo tipo di approccio è più "elastico" e nel caso di molte righe di dati più rapido nell'esecuzione.

ciao

Answer 2

Sempre volendo continuare con l'approcio del filtro prova qualcosa del genere:

File esempio: File esempio #2

'---

Option Explicit

Sub Macro_excel_per_compilare_campi_filtrati()

  Const sNomeFoglioTabella As String = "Foglio1"

  Const sPrimaCellaTabella As String = "A1"

  Const sColonnaFiltro As String = "J"

  Const sColonnaTesto As String = "F"

Const sColonnaDaCopiare As String = "O"

Const sColonnaInCuiIncollare As String = "R"

  Dim Twb As Workbook

  Dim WsTabella As Worksheet

  Dim rPrimaCella As Range

  Dim rTabella1 As Range

  Dim rTabella2 As Range

  Dim NumColFiltro As Long

  Dim rCelleFiltrate As Range

  Dim rCelleDaCopiare As Range

Dim CellaDaCopiare As Range

Dim OffSetInCuiIncollare As Long

  On Error GoTo Errore

  Set Twb = ThisWorkbook

  Set WsTabella = Twb.Worksheets(sNomeFoglioTabella)

  With Application

    .Calculation = xlCalculationManual

    .ScreenUpdating = False

    .EnableEvents = False

  End With

    With WsTabella

      With .Range(sPrimaCellaTabella)

        Set rPrimaCella = .Cells(1, 1)

        With .CurrentRegion

          Set rTabella1 = .Cells

          Set rTabella2 = .Offset(1).Resize(.Rows.Count - 1)

        End With

      End With

      NumColFiltro = .Columns(sColonnaFiltro).Column - rPrimaCella.Column + 1

      rTabella1.AutoFilter Field:=NumColFiltro, Criteria1:="=*LAN"

      On Error Resume Next

      Set rCelleFiltrate = Intersect(rTabella2.SpecialCells(xlCellTypeVisible), .Columns(sColonnaTesto))

      On Error GoTo Errore

      If Not rCelleFiltrate Is Nothing Then

        rCelleFiltrate.Value = "CD"

Set rCelleDaCopiare = Intersect(rTabella2.SpecialCells(xlCellTypeVisible), .Columns(sColonnaDaCopiare))

OffSetInCuiIncollare = .Columns(sColonnaInCuiIncollare).Column - .Columns(sColonnaDaCopiare).Column

For Each CellaDaCopiare In rCelleDaCopiare

With CellaDaCopiare

.Offset(, OffSetInCuiIncollare).Value = .Value

.ClearContents

End With

Next CellaDaCopiare

      End If

      Set rCelleFiltrate = Nothing

Set rCelleDaCopiare = Nothing

      rTabella1.AutoFilter Field:=NumColFiltro, Criteria1:="<>*LAN"

      On Error Resume Next

      Set rCelleFiltrate = Intersect(rTabella2.SpecialCells(xlCellTypeVisible), .Columns(sColonnaTesto))

      On Error GoTo Errore

      If Not rCelleFiltrate Is Nothing Then

        rCelleFiltrate.Value = "DVD"

      End If

      .ShowAllData

      rTabella1.AutoFilter

    End With 'WsTabella

    MsgBox "Elaborazione terminata.", vbInformation, "Macro_excel_per_compilare_campi_filtrati"

RiprendiErrore:

  With Application

    .Calculation = xlCalculationAutomatic

    .ScreenUpdating = True

    .EnableEvents = True

  End With

  Exit Sub

Errore:

  MsgBox "Errore n. " & Err.Number & vbNewLine & _

         Err.Description, vbCritical, "Errore VBA"

  Resume RiprendiErrore

End Sub

'---

Ho evindenziato in grassetto le parti modificate rispetto alla precedente.

N.B. mi sono accorto solo ora che nella precedente avevo dimenticato di impostare nuovamente in automatico il ricalcolo (vedi in grassetto xlCalculationAutomatic dopo .Calculation = ).

Edit: e solo ora mi accorgo che avevo lasciato su false anche le impostazioni ScreenUpdating  e EnableEvents !!!!

Answer 3

Ciao casanmaner, grazie per il supporto; funziona correttamente.

Ora, se dopo aver filtrato le celle che terminano per "LAN" anziché scrivere "CD" in colonna "F" volessi copiare in colonna "R" per ciascuna riga il valore corrispondente presente in colonna "O"  cancellandolo dalla colonna "O" come posso fare?

grazie

Guandrake

Answer 4

Ciao Guandrake,

nella mia precedente macro non ho tenuto conto del fatto che il filtro potrebbe portare a nessuna riga visibile.

Ho modificato così il precedente codice per tener conto di questa evenienza:

'---

Option Explicit

Sub Macro_excel_per_compilare_campi_filtrati()

  Const sNomeFoglioTabella As String = "Foglio1"

  Const sPrimaCellaTabella As String = "A1"

  Const sColonnaFiltro As String = "J"

  Const sColonnaTesto As String = "F"

  Dim Twb As Workbook

  Dim WsTabella As Worksheet

  Dim rPrimaCella As Range

  Dim rTabella1 As Range

  Dim rTabella2 As Range

  Dim NumColFiltro As Long

  Dim rCelleFiltrate As Range

  On Error GoTo Errore

  Set Twb = ThisWorkbook

  Set WsTabella = Twb.Worksheets(sNomeFoglioTabella)

  With Application

    .Calculation = xlCalculationManual

    .ScreenUpdating = False

    .EnableEvents = False

  End With

    With WsTabella

      With .Range(sPrimaCellaTabella)

        Set rPrimaCella = .Cells(1, 1)

        With .CurrentRegion

          Set rTabella1 = .Cells

          Set rTabella2 = .Offset(1).Resize(.Rows.Count - 1)

        End With

      End With

      NumColFiltro = .Columns(sColonnaFiltro).Column - rPrimaCella.Column + 1

      rTabella1.AutoFilter Field:=NumColFiltro, Criteria1:="=*LAN"

      On Error Resume Next

      Set rCelleFiltrate = Intersect(rTabella2.SpecialCells(xlCellTypeVisible), .Columns(sColonnaTesto))

      On Error GoTo Errore

      If Not rCelleFiltrate Is Nothing Then

        rCelleFiltrate.Value = "CD"

      End If

      Set rCelleFiltrate = Nothing

      rTabella1.AutoFilter Field:=NumColFiltro, Criteria1:="<>*LAN"

      On Error Resume Next

      Set rCelleFiltrate = Intersect(rTabella2.SpecialCells(xlCellTypeVisible), .Columns(sColonnaTesto))

      On Error GoTo Errore

      If Not rCelleFiltrate Is Nothing Then

        rCelleFiltrate.Value = "DVD"

      End If

      .ShowAllData

      rTabella1.AutoFilter

    End With 'WsTabella

    MsgBox "Elaborazione terminata.", vbInformation, "Macro_excel_per_compilare_campi_filtrati"

RiprendiErrore:

  With Application

    .Calculation = xlCalculationManual

    .ScreenUpdating = False

    .EnableEvents = False

  End With

  Exit Sub

Errore:

  MsgBox "Errore n. " & Err.Number & vbNewLine & _

         Err.Description, vbCritical, "Errore VBA"

  Resume RiprendiErrore

End Sub

'---

Il file di esempio lo trovi sempre al precedente link.

ciao

Answer 5

Ciao Guandrake,

premesso che, a mio parere, volendo si potrebbe fare quanto chiedi senza affidarsi ai filtri, prova a vedere se questa macro, che si basa sul tuo approcio, fa quanto chiedi.

Qui trovi un file di esempio: File Esempio

Questa la macro presente nel Modulo1:

'---

Option Explicit

Sub Macro_excel_per_compilare_campi_filtrati()

  Const sNomeFoglioTabella As String = "Foglio1"

  Const sPrimaCellaTabella As String = "A1"

  Const sColonnaFiltro As String = "J"

  Const sColonnaTesto As String = "F"

  Dim Twb As Workbook

  Dim WsTabella As Worksheet

  Dim rPrimaCella As Range

  Dim rTabella1 As Range

  Dim rTabella2 As Range

  Dim NumColFiltro As Long

  Dim rCelleFiltrate As Range

  On Error GoTo Errore

  Set Twb = ThisWorkbook

  Set WsTabella = Twb.Worksheets(sNomeFoglioTabella)

  With Application

    .Calculation = xlCalculationManual

    .ScreenUpdating = False

    .EnableEvents = False

  End With

    With WsTabella

      With .Range(sPrimaCellaTabella)

        Set rPrimaCella = .Cells(1, 1)

        With .CurrentRegion

          Set rTabella1 = .Cells

          Set rTabella2 = .Offset(1).Resize(.Rows.Count - 1)

        End With

      End With

      NumColFiltro = .Columns(sColonnaFiltro).Column - rPrimaCella.Column + 1

      rTabella1.AutoFilter Field:=NumColFiltro, Criteria1:="=*LAN"

      Set rCelleFiltrate = Intersect(rTabella2.SpecialCells(xlCellTypeVisible), .Columns(sColonnaTesto))

      If Not rCelleFiltrate Is Nothing Then

        rCelleFiltrate.Value = "CD"

      End If

      rTabella1.AutoFilter Field:=NumColFiltro, Criteria1:="<>*LAN"

      Set rCelleFiltrate = Intersect(rTabella2.SpecialCells(xlCellTypeVisible), .Columns(sColonnaTesto))

      If Not rCelleFiltrate Is Nothing Then

        rCelleFiltrate.Value = "DVD"

      End If

      .ShowAllData

      rTabella1.AutoFilter

    End With 'WsTabella

    MsgBox "Elaborazione terminata.", vbInformation, "Macro_excel_per_compilare_campi_filtrati"

RiprendiErrore:

  With Application

    .Calculation = xlCalculationManual

    .ScreenUpdating = False

    .EnableEvents = False

  End With

  Exit Sub

Errore:

  MsgBox "Errore n. " & Err.Number & vbNewLine & _

         Err.Description, vbCritical, "Errore VBA"

  Resume RiprendiErrore

End Sub

'---

Vedi se funziona con la tua tabella.

ciao