FOGLIO PRESTITO BIBLIOTECA SCOLASTICA, AIUTO PER CREARE IL COMANDO: SE COMPILI UNA CASELLA, COMPIA L'INTERA RIGA ED INCOLLALA IN AUTOMATICO NEL SECONDO FOGLIO.

Ciao Alessandra,

Oltre al suggerimento di Gianfranco, se la tua intenzione era che le righe filtrate dovessero essere copiate automaticamente in risposta alla selezione del criterio di filtro Sì, prova come segue:

• Inserisci un nuovo foglio (eventualmente nascosto)
• Nella cella A1 del nuovo foglio, imeeti la formula =SUBTOTALE(3;'BIBLIOTECA BES'!H:H)
• Fai clic dx sulla linguetta del nuovo foglio
• Seleziona l'opzione Visualizza Codice dal **** menu contestuale risultante
• Incolla il seguente codice:

'========>>

Option Explicit

'-------->>

Private Sub Worksheet_Calculate()

Dim srcSH  As Worksheet, destSH As Worksheet 

Dim Rng As Range, srcRng As Range, destrng As Range 

Dim sFilter As String 

Dim LRow As Long 

Const sFoglio\_sorgente As String = **"BIBLIOTECA BES"** 

Const sFoglio\_Destinazione As String = **"PRESTITI"** 

With ThisWorkbook 

    Set srcSH = .Sheets(sFoglio\_sorgente) 

End With 

Set Rng = srcSH.Range("H3") 

sFilter = FilterCriteria(Rng) 

If ThisWorkbook.Names("myFilter").Value <> sFilter And sFilter = "=Si" Then 

    ThisWorkbook.Names("myFilter").RefersTo = sFilter 

    With srcSH.AutoFilter.Range 

        Set srcRng = .Columns("A:H").Resize(.Rows.Count - 1).Offset(1) 

    End With 

    Set destSH = ThisWorkbook.Sheets(sFoglio\_Destinazione) 

    With destSH 

        LRow = LastRow(destSH, .Columns(1)) 

        Set destrng = destSH.Range("A" & LRow + 1) 

    End With 

    On Error GoTo XIT 

    Application.EnableEvents = False 

    With srcRng 

        .Copy Destination:=destrng 

        .EntireRow.Delete 

    End With 

  End If 

XIT:

ThisWorkbook.Names("myFilter").RefersTo = sFilter

Application.EnableEvents = True

End Sub

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

• Ctrl+R per accedere alla finestra Project Explorer ('Gestione progetti')
• Fai doppio clic sul modulo ThisWorkbook (Questa_cartella_di_Lavoro) del file e incolla il seguente codice:

'========>>

Option Explicit

'-------->>

Private Sub Workbook_Open()

Dim SH  As Worksheet 

Dim Rng As Range 

Dim oName As Name 

Dim sFilter As String 

Const sFoglio As String = "BIBLIOTECA BES" 

Set SH = Me.Sheets(sFoglio) 

Set Rng = SH.Range("H3") 

sFilter = FilterCriteria(Rng) 

On Error Resume Next 

Set oName = Me.Names(sName) 

On Error GoTo 0 

Me.Names.Add Name:=sName, RefersTo:=sFilter 

End Sub

'<<========

• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'========>>

Option Explicit

Public Const sName As String = "myFilter"

'-------->>

Public Function FilterCriteria(Rng As Range) As String

'#######################################################################

'\\  By Stephen Bullen 

'\ The single-cell argument for the FilterCriteria function

'\\  can refer to any cell within the column of interest. 

'\\  The formula will return the current AutoFilter criteria 

'\\  (if any) for the specified column. When you turn AutoFiltering 

'\\  off, the formulas don't display anything. 

'########################################################################

Dim Filter As String 

Filter = "-" 

On Error GoTo Finish 

With Rng.Parent.AutoFilter 

    If Intersect(Rng, .Range) Is Nothing Then GoTo Finish 

    With .Filters(Rng.Column - .Range.Column + 1) 

        If Not .On Then GoTo Finish 

        Filter = .Criteria1 

        Select Case .Operator 

            Case xlAnd 

                Filter = Filter & " AND " & .Criteria2 

            Case xlOr 

                Filter = Filter & " OR " & .Criteria2 

        End Select 

    End With 

End With 

Finish:

FilterCriteria = Filter 

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 < 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

Potresti scaricare il mio file di prova Alessandra20221017.xlsm

===

Regards,

Norman

ciao

circa il codice è questo

Sub CopiaeIncolla()

Application.ScreenUpdating = False

Set zona = ActiveSheet.Range([A2], [A2].End(xlDown))

contarighe = zona.Rows.Count

For N = 1 To contarighe Step 1

If Cells(N, 8).Value = "SI" Then

Cells(N, 8).EntireRow.Copy

Sheets("Prestiti").Select

Dim iRow As Integer

iRow = 2

While Cells(iRow, 1) <> ""

iRow = iRow + 1

Wend

Cells(iRow, 1).Select

ActiveSheet.Paste

Sheets(1).Select

Cells(N, 8).EntireRow.Delete

End If

Next

End Sub

https://www.dropbox.com/s/1ltj1x69wo2nc46/copia%20riga%20e%20elimina.xlsm?dl=0

metti dei si sulla convalida del foglio 1 e clicca il pulsante

se è quello che vuoi vedrai che i cvbaisti lo migliorano

ciao

un dubbio

se metti SI in I8

cosa succede

rimane sul foglio

vuoi copiare la riga in PRESTITI e cancellare la riga dal foglio BIBIOTECA BES

cosa vuoi fare?

perchè se la riga rimane sul foglio

non capisco cosa ti serva riportarla su un'altro visto che i dati li hai

e ti basta filtrare per vedere i dati.

ma è solo curiosità

Bravissimo Gian Franco,

l'idea è che una volta detto sì, le celle corrispondenti al prestito (F-G-H-I-J) si svuotino anche...avevo dimenticato di metterlo! In questo modo la gente potrebbe vedere di nuovo il materiale disponibile, ma rimarrebbe traccia dei plessi in cui è stato il bene.

PS. Ho eliminato la colonna STATO tanto era inutile...

Grazie!

ciao

un dubbio

se metti SI in I8

cosa succede

rimane sul foglio

vuoi copiare la riga in PRESTITI e cancellare la riga dal foglio BIBIOTECA BES

cosa vuoi fare?

perchè se la riga rimane sul foglio

non capisco cosa ti serva riportarla su un'altro visto che i dati li hai

e ti basta filtrare per vedere i dati.

ma è solo curiosità