Excel VBA: filtra e copia dalle prime 5 righe / celle

Ho una tabella di dati che viene ordinata in ordine decrescente nella colonna F. Ho quindi bisogno di copiare le prime 5 righe, ma solo i dati della colonna A, B, D e F (non le intestazioni). Vedere le immagini.

Sub top5() Sheets("Sheet1").Select If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then ActiveSheet.ShowAllData End If ActiveSheet.Range("$A$4:$T$321").AutoFilter Field:=3, Criteria1:="Dave" ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields. _ Clear ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add _ Key:=Range("F4:F321"), SortOn:=xlSortOnValues, Order:=xlDescending, _ DataOption:=xlSortTextAsNumbers With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ' This copy-paste part does what its supposed to, but only for the specific ' cells. Its not generalised and I will have to repeat this operation ' several times for different people Sheets("Sheet1").Select Range("A3:B15").Select Selection.Copy Sheets("Sheet2").Select Range("A3").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("D3:D15").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet2").Select Range("C3").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("F3:F15").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet2").Select Range("D3").Select ActiveSheet.Paste Application.CutCopyMode = False End Sub 

Ho pensato a cercare di adattare questo frammento di codice qui sotto utilizzando le funzioni delle cellule visibili, ma sono bloccato e non riesco a trovare qualcosa sulla networking che si adatta.

  • Devi salvare i dati inseriti in un altro foglio di lavoro
  • inserendo le righe dal valore selezionato
  • Perché questa formula excel restituisce risultati diversi per la formattazione condizionale?
  • excel macro per cercare un sito web e estrarre i risultati
  • Errore di errore di esecuzione di lavoro Excel 1004 metodo subtotale di class di intervallo non riuscito
  • Estrarre i dati da una tabella in Excel basata su un criterio
  •  ' This selects all rows (plus 1, probably due to offset), I only want parts of from the top 5. Sheets("Sheet1").Select ActiveSheet.Range("$A$4:$B$321").Offset(1, 0).SpecialCells(xlCellTypeVisible).Select Selection.Copy Sheets("Sheet2").Select Range("A3").Select ActiveSheet.Paste Sheets("Sheet1").Select ActiveSheet.Range("$D$4:$D$321").Offset(1, 0).SpecialCells(xlCellTypeVisible).Select Selection.Copy Sheets("Sheet2").Select Range("C3").Select ActiveSheet.Paste 

    Spero che il mio esempio ha senso e apprezzo molto il tuo aiuto!

    Esempio di tabella Excel

    Nota: i nomi di intestazione sono solo gli stessi nelle due tabelle per dimostrare che i dati sono gli stessi. Le intestazioni NON dovrebbero essere copiate. Inoltre, nella seconda tabella è presente un ulteriore spazio / spazio bianco. Una soluzione dovrebbe includere questo.

    I dati sono stati copiati in una nuova tabella

  • Copia di colonne specifiche da più cartelle di lavoro a una cartella di lavoro principale, senza modificare costantemente il codice
  • BI SSRS Esport in Excel genera il text come numero
  • WPF ResourceDictionary non è trovato in Plug-in di Excel 2013
  • Come analizzare il valore particolare da each cella in un database?
  • New Line Issue durante la copia dei dati da SQL Server 2012 a Excel
  • Voglio fare questo codice per funzionare per due variables che copia solo i dati della cella A1 nella colonna B, voglio che anche i dati della cella C1 nella colonna D vengano pure?
  • 6 Solutions collect form web for “Excel VBA: filtra e copia dalle prime 5 righe / celle”

    Innanzitutto alcuni punti utili:

    • Si dovrebbe fare riferimento a fogli di lavoro da lì Codice Nome per evitare problemi di ridenominazione.
    • Se vuoi lavorare con VBA allora il mio consiglio è di evitare le cellule unite come la peste. Causano danni con codice. Se ansible, utilizzare le celle di formato – allineamento – orizzontale – centrare la selezione
    • Raccommand inoltre di evitare i loops ovunque ansible e approfittare di eccellenze costruite in funzioni invece come esercizio di buone pratiche.

    Ecco la mia soluzione. Sempre semplice. Se hai bisogno di aiuto, lasciami ora.

     Sub HTH() Dim rCopy As Range With Sheet1.AutoFilter.Range '// Set to somewhere blank and unused on your worksheet Set rCopy = Sheet1.Range("A" & Rows.Count - (.Rows.Count)) .SpecialCells(xlCellTypeVisible).Copy rCopy End With With rCopy.Offset(1).Resize(5) '// Offset to avoid the header .Resize(, 2).Copy Sheet2.Range("A5") .Offset(, 3).Resize(, 1).Copy Sheet2.Range("D5") .Offset(, 5).Resize(, 1).Copy Sheet2.Range("F5") .CurrentRegion.Delete xlUp '// Delete the tempory area End With Set rCopy = Nothing End Sub 

    Un modo rapido per farlo è utilizzare Union e Intersect per copiare solo le celle desiderate. Se incollate valori (o i dati non sono una formula da avviare), questo funziona bene. Pensandoci, costruisce una serie di colonne per continuare a utilizzare Union e quindi Intersect che con le prime 5 righe di dati con 2 righe di intestazione. Il risultato è una copia di solo i dati desiderati con la formattazione intatta.

    Modifica solo le righe visibili di process, afferrando l'intestazione e quindi le prime 5 sotto le righe dell'intestazione

     Sub CopyTopFiveFromSpecificColumns() 'set up the headers first to keep Dim rng_top5 As Range Set rng_top5 = Range("3:4").EntireRow Dim int_index As Integer 'start below the headers and keep all the visible cells For Each cell In Intersect( _ ActiveSheet.UsedRange.Offset(5), _ Range("A:A").SpecialCells(xlCellTypeVisible)) 'add row to keepers Set rng_top5 = Union(rng_top5, cell.EntireRow) 'track how many items have been stored int_index = int_index + 1 If int_index >= 5 Then Exit For End If Next cell 'copy only certain columns of the keepers Intersect(rng_top5, _ Union(Range("A:A"), _ Range("B:B"), _ Range("D:D"), _ Range("F:F"))).Copy 'using Sheet2 here, you can set to wherever, works if data is not formulas Range("Sheet2!A1").PasteSpecial xlPasteAll 'if the data contains formulas, use this route 'Range("Sheet2!A1").PasteSpecial xlPasteValues 'Range("Sheet2!A1").PasteSpecial xlPasteFormats End Sub 

    Ecco il risultato che ottengo da alcuni dati fittizi impostati negli stessi intervalli come l'image sopra.

    Sheet1 con area copiata visibile

    sheet1

    Sheet2 con dati incollati

    Foglio2

    La prima parte della tua domanda, selezionando le celle visibili top5, è relativamente semplice, la copia e l'incollaggio sono where sono i problemi. Vedete, non puoi incollare una gamma, anche se non è uniforms, in una gamma non uniforms. Quindi dovrai scrivere la tua function Incolla.

    Parte 1 – Ottenere le righe Top5

    Ho usato una tecnica simile a @ Byron's. Si noti che questa è solo una function che restituisce un object Range e accetta una String , che rappresenta la tua gamma non uniforms (puoi cambiare il tipo di parametro in Range se vuoi).

     Function GetTop5Range(SourceAddress As String) As Range Dim rngSource As Range Dim rngVisible As Range Dim rngIntersect As Range Dim rngTop5 As Range Dim i As Integer Dim cell As Range Set rngSource = Range(SourceAddress) Set rngVisible = rngSource.SpecialCells(xlCellTypeVisible).Cells Set rngIntersect = Intersect(rngVisible, rngVisible.Cells(1, 1).EntireColumn) i = 1 For Each cell In rngIntersect If i = 1 Then Set rngTop5 = cell.EntireRow i = i + 1 ElseIf i > 1 And i < 6 Then Set rngTop5 = Union(rngTop5, cell.EntireRow) i = i + 1 Else Exit For End If Next cell Set GetTop5Range = Intersect(rngTop5, rngVisible) End Function 

    Parte 2 – Creazione della propria function di incollaggio

    Poiché Excel pasta sempre la tua gamma copiata come uniforms, devi farlo da soli. Questo metodo divide essenzialmente la regione di origine in colonne e li pasta singolarmente. Il metodo accetta il parametro SourceRange di tipo Range , che è inteso per il tuo range Top5 e un TopLeftCornerRange di tipo Range , che rappresenta la cella di destinazione del tuo incollaggio.

     Sub PasteRange(SourceRange As Range, TopLeftCornerRange As Range) Dim rngColumnRange As Range Dim cell As Range Set rngColumnRange = Intersect(SourceRange, SourceRange.Cells(1, 1).EntireRow) For Each cell In rngColumnRange Intersect(SourceRange, cell.EntireColumn).Copy TopLeftCornerRange.Offset(0, cell.Column - 1).PasteSpecial xlPasteValuesAndNumberFormats Next cell Application.CutCopyMode = False End Sub 

    Parte 3 – Eseguire la procedura

     Sub Main() PasteRange GetTop5Range("A2:B33,D2:D33"), Range("A35") End Sub 

    Questo è tutto.

    Nel mio progetto, avevo i dati di origine nelle colonne A, B e D come te e i risultati sono incollati per la gamma a partire da A35.

    Risultato:

    immettere qui la descrizione dell'immagine

    Spero che questo ti aiuti!

    Mentre potrebbe essere semplicemente più facile passare attraverso le prime cinque righe visibili, ho usato l'applicazione.valuta per elaborare una formula di foglio di lavoro che ha restituito il numero di row del quinto disco visibile.

     Sub sort_filter_copy() Dim lr As Long, lc As Long, flr As Long, rws As Long, v As Long Dim sCRIT As String Dim vCOLs As Variant, vVALs As Variant Dim bCopyFormulas As Boolean, bSort2Keys As Boolean bCopyFormulas = True bSort2Keys = False sCRIT = "dave" vCOLs = Array(1, 2, 4, 6) With Sheet1 lr = .Cells(Rows.Count, 1).End(xlUp).Row lc = .Cells(4, Columns.Count).End(xlToLeft).Column With .Cells(5, 1).Resize(lr - 4, lc) 'sort on column F as if there was no header If bSort2Keys Then .Cells.Sort Key1:=.Columns(6), Order1:=xlDescending, _ Key2:=.Columns(7), Order2:=xlDescending, _ Orientation:=xlTopToBottom, Header:=xlNo Else .Cells.Sort Key1:=.Columns(6), Order1:=xlDescending, _ Orientation:=xlTopToBottom, Header:=xlNo End If With .Offset(-1, 0).Resize(.Rows.Count + 1, .Columns.Count) .AutoFilter .AutoFilter field:=3, Criteria1:=sCRIT With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) rws = Application.Min(5, Application.Subtotal(103, .Columns(3))) If CBool(rws) Then flr = Application.Evaluate("=small(index(rows(5:" & lr & ") + ('" & Sheet1.Name & "'!C5:C" & lr & "<>" & Chr(34) & sCRIT & Chr(34) & ")*1e99, , ), " & rws & ")") For v = LBound(vCOLs) To UBound(vCOLs) If .Columns(vCOLs(v)).Cells(1).HasFormula And bCopyFormulas Then Sheet2.Cells(3, vCOLs(v)).Resize(5, 1).FormulaR1C1 = _ .Columns(vCOLs(v)).Cells(1).FormulaR1C1 Else .Columns(vCOLs(v)).Resize(flr - 4, 1).Copy _ Destination:=Sheet2.Cells(3, vCOLs(v)) End If Next v End If End With .AutoFilter End With 'uncomment the next line if you want to return to a standard ascending sort on column A '.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _ Orientation:=xlTopToBottom, Header:=xlNo End With End With End Sub 

    Tutte le opzioni sono impostate appena sotto le dichiarazioni delle variables. Le immagini del campione sembravano indicare che hai usato un tipo di due caratteri in modo da codificarlo in modo opzionale. Se vuoi inserire formule come formule, questa opzione è presente. I criteri di filter e le colonne da copiare sono assegnati anche alle loro rispettive.

    Ordina, filtra e copia Top 5

    La mia cartella di lavoro di esempio è disponibile sul mio Dropbox Pubblico a:
    Sort_Filter_Copy_from_Top_5.xlsb

    Prova questo:

     Sub GetTopFiveRows() Dim table As Range, cl As Range, cnt As Integer Set table = Worksheets("Sheet1").Range("A2:A10").SpecialCells(xlCellTypeVisible) cnt = 1 With Worksheets("Sheet2") For Each cl In table If cnt <= 5 Then .Range("A" & cnt) = cl .Range("B" & cnt) = cl.Offset(0, 1) .Range("D" & cnt) = cl.Offset(0, 3) .Range("F" & cnt) = cl.Offset(0, 5) cnt = cnt + 1 Else Exit Sub End If Next cl End With End Sub 
    • Innanzitutto un riferimento è impostato su solo righe visibili nell'intera tabella (devi aggiornare il riferimento della gamma)
    • Poi ci avvolgiamo sull'intervallo visibile, copiamo sul foglio 2 e fermiamo quando sono state copiate 5 record (cioè i primi cinque)

    Innanzitutto sbloccare le celle quindi utilizzare questo codice, molto simile ad alcuni degli altri suggerimenti.

      Sub Button1_Click() Dim sh As Worksheet Dim Rws As Long, Rng As Range, fRng As Range, c As Range, fRw As Long Set sh = Sheets("Sheet2") Rws = Cells(Rows.Count, "A").End(xlUp).Row Set Rng = Range(Cells(4, 1), Cells(Rws, "T")) 'unmerge all the headers Rng.AutoFilter Field:=3, Criteria1:="Dave" ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields. _ Clear ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add _ Key:=Range("F4:F321"), SortOn:=xlSortOnValues, Order:=xlDescending, _ DataOption:=xlSortTextAsNumbers With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Set fRng = Range(Cells(5, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeVisible) x = 0 For Each c In fRng.Cells If x = 5 Then Exit Sub fRw = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1 sh.Range(sh.Cells(fRw, 1), sh.Cells(fRw, 2)).Value = Range(Cells(c.Row, 1), Cells(c.Row, 2)).Value sh.Cells(fRw, 4).Value = Cells(c.Row, 4).Value sh.Cells(fRw, 6).Value = Cells(c.Row, 6).Value x = x + 1 Next c End Sub 
    Microsoft Office Excel Spreadsheet è il miglior software di Office, Excel VBA e formule Excel rendono il foglio di calcolo più veloce.