Beillesztés szűrt táblázatba – VBA

Power BI Desktop alapok Hamarosan Megnézem Két Online délelőtt PowerQuery bevezető Hamarosan Megnézem Két online délelőtt Videó Megnézem - Excel makró alapok - Power BI alapok - Excel PIVOT mester Tanfolyamok - PowerQuery alapok

Az előző részben azt mutattam meg, hogy hogyan lehet egy szűrt, azaz rejtett sorokat is tartalmazó tartományba adatokat beilleszteni makró használata nélkül.

Arra jutottunk, hogy ez csak akkor lehetséges, és úgy sem egyszerűen, ha ugyanazon szűrt táblázat egyik oszlopából szeretnénk másolni adatokat egy másik oszlopba. Mivel egy táblában vannak garantált, hogy a szűrés hatására mindkét oszlopban ugyanazok a sorok leszek rejtve.

A példában a szűrés után a C oszlop adatait másoljuk a B oszlopba.

De mi van akkor, ha a másolandó és a céltartomány nem ugyanabban a táblázatban van?

Esetleg másik lapon, ami akár nem is szűrt?

Ez esetben makrót kell használni. Szerencsétek van, mert levadásztam, kipróbáltam, és itt közzéteszem a programot. Futtatáskor csak ki kell jelölni a forrás tartományt, majd a céltartomány első celláját, és a többit rábízni a makróra.

A makró használatát és működését Videóban is megmutatom.

A makró kódja

'Beillesztés szűrt tartományba, 1 oszlopos megoldás
'A forrástartományt ki kell jelölni, a Céltartománynak csak a kezdőcelláját kell megadni
'A céltartomány legyen/lehet szűrt oszlopban
'Az átmásolás értékként történik
Sub Paste2VisRows2()

Dim rFrom As Range, rTo As Range
Dim i As Long, Ofset As Long

Set rFrom = Application.InputBox(Prompt:="Please select copy area", Title:="Area Selection", Type:=8)

Set rTo = Application.InputBox(Prompt:="Please select the first cell of paste area", Title:="Area Selection", Type:=8)

If rFrom.Columns.Count > 1 Or rTo.Columns.Count > 1 Then
   MsgBox "Both source and destination ranges must be one column wide!"
Exit Sub
End If

If rTo.Cells.Count <> 1 Then
   MsgBox "Select only one cell as the beginning of the paste area!"
Exit Sub
End If

Application.ScreenUpdating = False

Ofset = 0
For i = 1 To rFrom.Rows.Count
  If Not rFrom.Rows(i).Hidden Then
    Do Until Not rTo.Offset(Ofset).EntireRow.Hidden
      Ofset = Ofset + 1
    Loop
    rFrom.Cells(i).Copy
    rTo.Offset(Ofset).PasteSpecial xlPasteValues 'Átmásolja az aktuális cellát a forráshelyről a célhelyre
    Ofset = Ofset + 1
  End If
Next i
Application.ScreenUpdating = True
End Sub

Letölthető munkafüzet: beillesztes-szurt-tartomanyba