Forum Discussion
VBA
[Copiare le celle filtrate in un altro foglio]
Ho registrato una macro per copiare le celle filtrate dal foglio VERIFICA al foglio MODULO
Questo è il codice:
Public Sub Quinta()
'Applicare un filtro al foglio 'VERIFICA', filtro di testo <> "Non disp"
Sheets("Verifica").Select
Range("B2").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C$19").AutoFilter Field:=2, Criteria1:= _
"<>NON DISPON", Operator:=xlAnd
End Sub
Public Sub Sesta()
' copio i valori filtrati nel foglio MODULO
Sheets("Verifica").Select
Range("A5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("modulo").Activate
Range("A10").Select
ActiveSheet.Paste
Sheets("verifica").Activate
Range("B5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("modulo").Activate
Range("C10").Select
ActiveSheet.Paste
Sheets("verifica").Activate
Range("C5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("modulo").Activate
Range("D10").Select
ActiveSheet.Paste
End https://we.tl/t-KYR0rQdWBB
Come faccio a rendere indipendente la cella da cui partire la copia?
Adesso è Range("A5").Select
Ma se mi arrivano altri dati la cella da cui partire potrebbe essere diversa: esempio Range("A1").Select
Allego il file
Grazie delle risposte
2 Replies
Public Sub Sesta() ' copio i valori filtrati nel foglio MODULO Sheets("Verifica").Range("A2:A19").Copy Destination:=Sheets("Modulo").Range("A10") Sheets("Verifica").Range("B2:B19").Copy Destination:=Sheets("Modulo").Range("B10") Sheets("Verifica").Range("C2:C19").Copy Destination:=Sheets("Modulo").Range("D10") End Sub- I need to copy the results of the CHECK sheet filter into the MODULE sheet:
The code from cell A10, the description from cell D10, and the quantity from cell D10
The filtered area is a table with 3 columns:
Code, description and quantity
400.3287 PRESA INCASSO OMNIA 3P+N 32A 6h IP44 N.ordine: 54000621 Posizione: 1390 120
405.6386 PRESA INCASSO OMNIA 63A 3P+T 6h IP67 N.ordine: 54000621 Posizione: 16300 42
505.1683 PR.PAR.OMNIA 2P+T16A 220V IP67 N.ordine: 54000621 Posizione: 4880 108
505.1686 PR.PAR.OMNIA 3P+T16A 380V IP67 N.ordine: 54000621 Posizione: 4960 60
505.6386 PRESA OMNIA S/FUS. 3P+T 63A 6h IP66/67 N.ordine: 54000621 Posizione: 16430 36
I can copy the code, description; but i can't copy the quantityEcco il risultato
400,3287 PRESA INCASSO OMNIA 3P+N 32A 6h IP44 N.ordine: 54000621 Posizione: 1390
405,6386 PRESA INCASSO OMNIA 63A 3P+T 6h IP67 N.ordine: 54000621 Posizione: 16300
505,1683 PR.PAR.OMNIA 2P+T16A 220V IP67 N.ordine: 54000621 Posizione: 4880
505,1686 PR.PAR.OMNIA 3P+T16A 380V IP67 N.ordine: 54000621 Posizione: 4960
505,6386 PRESA OMNIA S/FUS. 3P+T 63A 6h IP66/67 N.ordine: 54000621 Posizione: 16430
Ecco il codice
Public Sub sesta()
Dim Cella As Range
Dim Rng As Range
Dim FilRange As Range
Dim Dict As Dictionary
Dim i As Long
Sheets("Modulo").Select
'***ATTENZIONE***
'Aggiungere libreria "Microsoft Scripting Runtime" da Strumenti->Riferimenti
'I create the instance of the variable of type Dictionary
Set Dict = New Dictionary
'I assign to the variable Rng the intersection between the current zone with A1 and the rejection of a line
'always in the current zone to exclude the header from the range
With Sheets("Verifica")
Set Rng = INTERSECT(.Range("A1").CurrentRegion, .Range("A1").CurrentRegion.Offset(1))
End With
'I assign to the variable only the visible lines of the previous variable
Set FilRange = Rng.SpecialCells(xlCellTypeVisible).EntireRow
'I start a loop for each line of the FilRange variable "visible lines"
For Each Cella In FilRange.Rows
'if the Dictionary does not exist
If Not Dict.Exists(Cella.Cells(1).Value) Then
'I add the key and as objects I load the description
Dict(Cella.Cells(1).Value) = Array(Cella.Cells(2))
'load the quantity
' Dict(Cella.Cells(2).Value) = Array(Cella.Cells(3))
Else
'se esite gia' aggiungo agli oggetti matrice
Dict(Cella.Cells(1).Value) = Array(Dict(Cella.Cells(1).Value)(0) & ", " & Cella.Cells(2), Dict(Cella.Cells(1).Value)(1))
End If
Next Cella
'I loop for each value of the Dictionary
For i = 0 To Dict.Count - 1
'I write the municipality (contained in the key of the Dictionary)
Cells(i + 10, 1) = Dict.Keys()(i)
'I add the description as the first array
Cells(i + 10, 3) = Dict.Items(i)(0)
'I add the quantity (contained in the Dictionary object as a second array)
'Cells(i + 10, 4) = Dict.Items(i)(1)
Next
'I undermine the variables
Set Rng = Nothing
Set FilRange = Nothing
Set Dict = Nothing
End Sub
