Macro voor tabelkop zoeken en waardes eronder kopieren

[GercoTermaat]

Beste helpers,

Ik wil uit een rapport, wat gemaakt is door Solidworks, de boorbewerkingen kopieren.
De boorbewerkingen staan heel mooi onder elkaar in een tabel. Maar de positie van deze tabel is onbekend.

Wat ik heb:
Ik zoek in een blad naar een waarde, namelijk "--Description--". Deze cel zit ergens in kolom B. Vervolgens zet ik een filter op deze cel waarin alleen "drill" te zien is.
Uit deze selectie wil ik de waardes onder de rij van "--Description--" in kolom A,F en K kopiëren in plakken in S1,T1 en U1.
Dit is gelukt.

Probleem:
Zoals gezegd is de positie van de tabel onbekend. Ik wil dus 1 rij onder de gezochte waarde zitten en selecteren tot het eind. Nou ben ik redelijk nieuw met VBA en kan ik dit niet zo schrijven dat dit werkt.

De code die ik tot nu toe heb:

Sub Kopieren()
'
' Kopieren Macro
'

'
   Cells.Find(What:="--Description--", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveSheet.Range("$A$270:$L$466").AutoFilter Field:=2, Criteria1:="Drill"
    
    Range("A271").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("S1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    Range("F271").Activate
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("T1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    Range("K271").Activate
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("U1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    ActiveSheet.Range("$A$270:$L$270").AutoFilter

End Sub

"--Description--" is gevonden in B270. A271, F271 en K271, tot het eind, zijn de waardes die ik nodig heb.

Bestand:
Bekijk bijlage macrotest.xlsm

Ik hoop dat mijn probleem duidelijk is en dat jullie mij kunnen helpen.

Alvast bedankt,
Gerco Termaat

 

[Gijsbert1]

Probeer dit eens:

Sub Kopieren()
Dim Description As Range
With Worksheets(1).Range("A:N")
    Set Description = .Find(What:="--Description--", LookIn:=xlValues)
    Rows(Description.Row).SpecialCells(xlCellTypeConstants).AutoFilter Field:=2, Criteria1:="Drill"
    Union(Range(Description.Offset(1, -1), Description.Offset(1, -1).End(xlDown)), _
    Range(Description.Offset(1, 4), Description.Offset(1, 4).End(xlDown)), _
    Range(Description.Offset(1, 9), Description.Offset(1, 9).End(xlDown))).Copy
    Range("S1").PasteSpecial Paste:=xlPasteValues
End With
End Sub

 

[GercoTermaat]

Gijsbert1,

Hartelijk bedankt voor je hulp.
Het werkt nu.
Toch leuk om te zien hoe lang mijn code was in vergelijking met die van jou.

 

[VenA]

Als je alle selects, selections activate uit jouw eigen code haalt dan wordt het ook al een stuk korter en efficiënter

Als alternatief

Sub VenA()
Dim f As Range
ReDim ar1(2, 0)
With Blad1
  Set f = .Columns(2).Find("--Description--")
  If Not f Is Nothing Then
    ar = Cells(f.Row, 1).CurrentRegion
      For j = 3 To UBound(ar)
      If ar(j, 2) = "Drill" Then
        ar1(0, t) = ar(j, 1)
        ar1(1, t) = ar(j, 6)
        ar1(2, t) = ar(j, 7)
        ReDim Preserve ar1(2, UBound(ar1, 2) + 1)
        t = t + 1
      End If
    Next j
    .Cells(1, 19).Resize(UBound(ar1, 2) + 1, UBound(ar1) + 1) = Application.Transpose(ar1)
  End If
  End With
End Sub

 

[GercoTermaat]

VenA,

Bedankt voor je reactie.
Ik maak de meeste macro's door ze op te nemen, kan inderdaad een stuk efficiënter.