Excel VBA: En iyi 5 satır/hücreden filtreleyin ve kopyalayın

F sütununda azalan sırada sıralanmış bir veri tablosuna sahibim. Daha sonra ilk 5 satırı kopyalamam gerekiyor, ancak yalnızca A, B, D ve F sütunlarından (başlıkları değil) verileri kopyalamam gerekiyor. Resme bak.

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

Aşağıdaki kod pasajını görünür hücreler işlevini kullanarak uyarlamaya çalışmayı düşündüm, ama sıkıştım ve ağda uyan hiçbir şey bulamıyorum.

' 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

Umarım benim örneğim anlamlıdır ve yardımın için minnettarım!

Sample Excel table

Not: Başlık adları, verilerin aynı olduğunu göstermek için iki tabloda yalnızca aynıdır. Başlıklar kopyalanmamalı. Ek olarak, ikinci tabloda fazladan bir sütun/beyaz boşluk var. Bir çözüm bunu içermelidir.

Data copied to new table

2
a) Örnek kodunuz, hedef çalışma sayfasının 3. satırına yapıştırılan kopyalanan sonuçları gösterir, ancak örnek resimleriniz 5. satırı gösterir. Gerçek hedef satır nedir? b) Hedef çalışma sayfasının C ve E sütunlarında “boşluk” un korunması gerekli midir? Orada bir blok yapıştırma ile üzerine yazılabilecek değerler olabilir mi?
katma yazar Jeeped, kaynak
Bir Do ... Loop bloğu snippet'inizle harikalar yaratabilir. Sadece sıralar arasında döngü yapın ve 5 satır kopyaladığınızda döngüden çıkın.
katma yazar Mr. Mascaro, kaynak
Bu nasıl @ jbarker2160 görünüyor? Görünür satırlarda nasıl dolaşırım? Ne demek istediğini biliyorum ama nasıl uygulanacağını bilmek istiyorum.
katma yazar E_L, kaynak
Merhaba @Jeeped. Bu aslında işyerindeki bir rapor içindir, bu yüzden gerçek verilerden veya raporlardan hiçbirini açıkça veremem. Bu tablo ve bunun gibi iki kişi, bir tablo ve grafik sayfasının ortasındadır ve boşluk alanını değiştiremem, böylece bir blok seçimi, yapıştırma, silme türü yaklaşımı işe yaramaz. Ayrıca, yalnızca F sütunu için işlemi gösteririm, ancak bunu H sütununda ve sonra tekrar J'de tekrarlardım. Kopyalanan tüm veriler yeni sütunlarda aynı sütunlarda (yani, A, B, D ve F) olur. sayfa ancak aynı tabloda değil.
katma yazar E_L, kaynak

6 cevap

Öncelikle birkaç faydalı nokta:

  • Çalışma sayfalarına şuradan başvurmalısınız: Kod Adı sorunları yeniden adlandırmaktan kaçının.
  • VBA ile çalışmak istiyorsanız tavsiyem veba gibi birleştirilmiş hücrelerin oluşmamasıdır. Kodla tahribata yol açıyorlar. Mümkünse, format hücrelerini kullanın - hizalama - yatay - ortadaki seçim
  • Ayrıca, mümkün olan her yerde döngülerden kaçınmanızı ve bunun yerine işlevlerde yerleşik excellerden yararlanmanızı öneririm iyi bir uygulama alıştırması olarak.

İşte benim çözümüm. Basit tut. Daha fazla yardıma ihtiyacınız olursa, şimdi izin verin.

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
2
katma
Harika, sizin için çalıştığına sevindim. Evet, bazen birleştirilmiş hücreler kaçınılmazdır, sadece son çare olmasını sağlayın. Bu yüzden döngüler de var ama mümkün olduğunda bunlardan kaçınmak, genellikle yerleşik özelliklerden yararlanmanızdan daha hızlı kod çalıştırılmasına neden olacaktır.
katma yazar Reafidy, kaynak
1. Bu ilginç, bunu bilmiyordum! Gelecekte kesinlikle bunu kullanmaya bakacağız. 2. Üzgünüm dostum, birleştirilmiş hücreler benim tercihim değil. Şu an için değiştiremeyeceğim bir şey. 3. Evet. Katılıyorum. Ama aynı zamanda bildiklerinizle çalışmak zorundasınız ve şu anda pek bir şey bilmiyorum ;-)
katma yazar E_L, kaynak
Bir miktar titremeyle, kodun hangi parçasının ne yaptığını anlayabildim ve isteğimi yerine getirdim. Çok teşekkürler. Oldukça basitti ve döngü eksikliğinden hoşlanıyordum.
katma yazar E_L, kaynak

Bunu yapmanın hızlı bir yolu, yalnızca istediğiniz hücreleri kopyalamak için Union ve Intersect kullanmaktır. Değerleri yapıştırıyorsanız (veya veriler başlamak için bir formül değilse), bu iyi sonuç verir. Bunu düşünerek, Union 'ı ve ardından Intersect ' i kullanmaya devam etmek için 2 başlık satırına sahip ilk 5 veri satırına sahip bir dizi sütun oluşturur. Sonuç, yalnızca biçimlendirme bozulmamış olarak istediğiniz verilerin bir kopyasıdır.

Yalnızca görünen satırları işlemden geçirin, başlığı tutun ve ardından başlık satırlarının altındaki ilk 5

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

İşte yukarıdaki resimle aynı aralıkta ayarlanmış bazı sahte verilerden aldığım sonuç.

Kopyalanan aralık görünür halde Sayfa1

Sheet1

Yapıştırılmış veri içeren sayfa2

Sheet2

1
katma
İyi bir nokta. Yukarıdaki resimde bir sebepten dolayı sıralandıklarını düşündüm. Kodu yalnızca görünür satırları alacak şekilde düzenledim.
katma yazar Byron Wall, kaynak
Bu iyi görünüyor, ancak filtrelenmiş verileri kopyalamıyor ... bana en iyi 5 satırı veriyor, ama Dave için filtrelendikten sonra ilk 5 satırı değil ...: -s
katma yazar E_L, kaynak
Oooh çok yakın! Sadece iki şey - başlıkları bir sorun olduğunu kanıtlıyor, özellikle bazıları birleştirilmiş hücreler olduğu için. Sadece onlardan uzak durmam gerektiğini düşünüyorum, ancak "set rng_5" kod satırının 4. satırını çıkarmak alt programda problemler yaratır. Bunu nasıl düzeltebilirim? Bir çeşit "rng_5 boşsa, ilk satıra ayarla" mı? İkincisi, kopyalanan kağıda bazı sütun dolguları var - bunu kesişime nasıl dahil edebilirim? FYI, kopyaladığım sütunlardan biri, sütun D, ​​formüllere sahip.
katma yazar E_L, kaynak
Yo! @Bron Duvar. Bana yardım etme ihtimalin var mı? Bunun hakkında çok düşündüm ve çok fazla googling araştırması yapıyorum ama bu konuda bana yardımcı olacak doğru bilgiyi bulamıyorum. Bana yardım edebilir misin?
katma yazar E_L, kaynak

Önce hücreleri çözün, sonra diğer önerilerin bazılarına çok benzeyen bu kodu kullanın.

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

İlk beş görünür satır boyunca döngü yapmak daha kolay olsa da, beşinci görünür kaydın satır sayısını döndüren bir çalışma sayfası stili formülü işlemek için application.evaluate kullandım.

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

Tüm seçenekler değişken bildirimlerinin hemen altında ayarlanır. Örnek resimleriniz, iki anahtar sıralama kullandığınızı gösteriyor, bu yüzden isteğe bağlı olarak kodladım. Herhangi bir formülü formül olarak getirmek istiyorsanız, bu seçenek orada. Filtre kriterleri ve kopyalanacak sütunlar kendi değişkenlerine de atanmıştır.

        Sort, Filter and Copy Top 5

My sample workbook is available on my public DropBox at:
      Sort_Filter_Copy_from_Top_5.xlsb

0
katma

Bunu dene:

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
  • Öncelikle bir referans tüm tablodaki yalnızca görünür satırlara ayarlanmıştır (aralık referansını güncellemeniz gerekir)
  • Ardından görünür aralığın üzerinde dolaşır, 2. sayfaya kopyalar ve 5 kayıt (yani ilk beş) kopyalandığında dururuz
0
katma

Sorunuzun ilk kısmı, en üstteki 5 görünür hücreyi seçmek, nispeten kolaydır, kopyalama ve yapıştırma, problemin olduğu yerdir. Görüyorsunuz, tek tip olmasa bile bir aralığı tek tip aralığa yapıştıramazsınız. Yani kendi Yapıştırma fonksiyonunuzu yazmanız gerekecek.

Bölüm 1 - Top5 satırlarını alma

Benzer bir tekniği @ Byron'a da kullandım. Bunun yalnızca bir Range nesnesi döndüren ve düzgün olmayan aralığınızı temsil eden bir String döndüren bir işlev olduğuna dikkat edin (parametre türünü Aralık dilerseniz).

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

2. Bölüm - Kendi yapıştırma işlevinizi oluşturma

Excel, kopyalanan aralığınızı her zaman tek tip olarak yapıştırdığından, bunu kendiniz yapmanız gerekir. Bu yöntem aslında kaynak bölgenizi sütunlara ayırır ve ayrı ayrı yapıştırır. Bu yöntem, Top5 aralığınız için ifade edilen Range türündeki SourceRange parametresini ve yapıştırmanızın hedef hücresini temsil eden Range türündeki TopLeftCornerRange türünü kabul eder.

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

Bölüm 3 - Prosedürü yürütme

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

Bu kadar.

Projemde sizler gibi A, B ve D sütunlarındaki kaynak verilerim vardı ve sonuçlar A35'ten başlayarak aralıklara yapıştırıldı.

Sonuç:

enter image description here

Bu yardımcı olur umarım!

0
katma