Telefonszámunk: 1-472-0679

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

2013-05-22 - horvimi - Megtekintések száma: 1,870 - Kategória: Macro-VBA, Tartományok kezelése
Hivatkozott Excel verzio:

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.

szurt-taomany-masolas

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 elkészítettem, é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

  • Másolás szűrt tartományba makróval

Vélemény, hozzászólás?