Questa richiesta era rimasta perduta nelle retrovie…
Diciamo che conosciamo la posizione dove comincia la tabella di origine, l' elenco delle intestazioni di colonna che ti servono, dove vanno incollate.
Assumiamo inoltre che "sotto la tabella" (nelle righe piu' alte dopo la fine della tabella) non ci siano altri dati (altrimenti ti chiedero' anche su quale riga finisce la tabella)
Con questi presupposti potresti usare una macro come questa:
- Codice: Seleziona tutto
Sub femotab()
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=103276
'
Dim myHead0 As String, tabRows As Long, mySource As String, myDest As String, myHead1 As String, myFields, JJ As Long
mySource = "Foglio1" '<<< Il foglio con la tabella da copiare
myHead0 = "B3" '<<< La cella di inizio della tabella sorgente
myDest = "Foglio2" '<<< Il foglio dove incollare
myHead1 = "A1" '<<< La cella dove iniziare a incollare
myFields = Array("Due", "Tre", "Cinq", "Ott") '<<< Le intestazioni dei campi da copiare
'
Sheets(mySource).Select
With Range(Range(myHead0), Range(myHead0).End(xlToRight))
myHead = .Address
tabRows = .EntireColumn.Find(What:="*", LookIn:=xlValues, After:=Range(myHead0), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - Range(myHead0).Row + 1
For Each cella In Range(myHead)
If Not IsError(Application.Match(cella.Value, myFields, 0)) Then
Sheets(myDest).Range(myHead1).Offset(0, JJ).Resize(tabRows, 1).Value = cella.Resize(tabRows, 1).Value
JJ = JJ + 1
End If
Next cella
End With
End Sub
Le righe marcate <<< vanno personalizzate
Nell' esempio ho immaginato di avere una tabella con 10 colonne (con intestazione Una, Due, Tre, …); ho inoltre immaginato che ti basta incollare i valori, non i formati.
Prova e fai sapere…
Ciao