Temat: Kopiuj kolumne numer.... (VBA)

Hej,

mam nr kolumny w polu A1 w Arkuszu1. Chcialbym by makro pobralo nr tej kolumny (wynik podaj pozycje) zalozylo filtr na te kolumny (tylko niepuste) i skopiowalo to co wyszlo w tej kolumnie. POmozecie z makrem, bo nie mam pomyslu. Szczegolnie nei wiem jak skopiowac kolumne o numerze np. 3 (C:C)

Z gory dziekuje za pomoc.
Pozdrawiam

Temat: Kopiuj kolumne numer.... (VBA)

Lekko brakuje danych.
Założenia:
Tabela z danymi jest w Arkusz1, jej lewy górny róg to C1
Kryterium filtrowania: >3 :)
Kopiujemy z nagłówkiem
Miejsce, w którym lądują dane to Arkusz2, komórka A1
+2 to korekta uwzględniająca lokalizację tabeli z danymi w arkuszu. Zmienna "Kolumna" to numer kolumny w tabeli z danymi, natomiast potem potrzebny jest adres w arkuszu, dlatego skoro C1 to +2.

Sub Filtruj()

Dim Kolumna As Integer 'numer kolumny tabeli z danymi, nie arkusza

Dim Ostatni_w As Long 'ostatni wiersz po filtrowaniu

Dim zakres As Range 'zakres odfiltrowany do kopiowania z nagłówkiem



With Sheets("Arkusz1")

    On Error Resume Next

    .ShowAllData

    On Error GoTo 0

    Kolumna = .Range("a1")

    .Range("C1").CurrentRegion.AutoFilter Field:=Kolumna, Criteria1:=">3"

    Ostatni_w = .Range(.Cells(.Rows.Count, Kolumna+2).Address).End(xlUp).Row

    Set zakres = .Range(.Cells(1, Kolumna + 2), .Cells(Ostatni_w, Kolumna + 2)).SpecialCells(xlCellTypeVisible)

    zakres.Copy Sheets("Arkusz2").Range("A1")

End With



End Sub

Ten post został edytowany przez Autora dnia 27.05.14 o godzinie 11:19

Temat: Kopiuj kolumne numer.... (VBA)

Witam,

na wstepie bardzo dziekuje za odpowiedź, jednak troche sie chyba nie zrozumielismy - widocznie za malo danych podalem.

Posluze sie teraz obrazkiem, by lepiej wytlumaczyc problem:





W arkuszu 1 mam baze danych, w kolumnach sa dane i sa puste miejsca.
W Arkuszu 2 mam pole w ktorym chce wpisac nazwe kolumny (badz jej nr) i chce by makro przefiltorowalo mi ta kolumne tak by nie bylo pustych miejsc i skopiowalo ta kolumne do Arkusza 2 do kolumny A (na zdjeciu przyklad wykonany na podstawie kolumny 2)

Bardzo dziekuje za wszelka pomoc

Temat: Kopiuj kolumne numer.... (VBA)

Tak naprawdę to nie wiem po co Ci makro do tego zadania (choć być może istnieje po temu racjonalna potrzeba)
Formułki by sobie poradziły spokojnie z czymś takim.... no może gdybyś miał naprawdę spory zakres danych i duzo innych formuł w arkuszu, to lepiej byłoby VBA zastosować.(choć niekoniecznie zawsze to musi być prawda).
Daj jakiś link do przykładowego pliku to popatrzymy co i jak (bo jeszcze probny arkusz robić to już za dużo dla mnie ;-))))
Pozdrawiam

Temat: Kopiuj kolumne numer.... (VBA)

Można to zrobić prostą pętlą

Sub test()

Set shDane = ActiveWorkbook.Sheets(1)
Set shCel = ActiveWorkbook.Sheets(2)

k = shCel.Cells(1, 4).Value

max_w = shDane.Cells(Rows.Count, k).End(xlUp).Row
j = 2

For i = 2 To max_w
If shDane.Cells(i, k).Value <> "" Then
shCel.Cells(j, 1) = shDane.Cells(i, k).Value
j = j + 1
End If
Next i

End Sub

Temat: Kopiuj kolumne numer.... (VBA)

Do tego zadania można wykorzystać filtr zaawansowany

Sub Kopiuj_Niepuste()



Dim shSrc As Excel.Worksheet    'Arkusz źródłowy

Dim shDest As Excel.Worksheet   'Arkusz docelowy

Dim rngTmp As Excel.Range       'Zakres do skopiowania

Dim lLstRwSrc&                  'Ostatnia zapisana komórka w wybranej kolumnie

Dim vKol As Variant             'Nagłówek kolumny do skopiowania

Dim iKol%                       'Numer kolumny do skopiowania na podstawie wpisanego nagłówka



Set shSrc = Sheets("Arkusz1")

Set shDest = Sheets("Arkusz2")



With shDest

    vKol = .Cells(1, 4).Value

    .Cells(2, 4).Value = "<>"

End With

With shSrc

    On Error Resume Next

    iKol = Application.Match(vKol, .Range("1:1"), 0)

    On Error GoTo 0

    If iKol = 0 Then

        MsgBox "Nie znaleziono podanego nagłówka kolumny."

        shDest.Cells(2, 4).ClearContents

        Exit Sub

    End If

    lLstRwSrc = .Cells(Rows.Count, iKol).End(xlUp).Row

    Set rngTmp = Range(.Cells(1, iKol), .Cells(lLstRwSrc, iKol))

    rngTmp.AdvancedFilter xlFilterCopy, Range(shDest.Cells(1, 4), shDest.Cells(2, 4)), shDest.Cells(1, 1), False

End With

    shDest.Cells(2, 4).ClearContents

End Sub