GoldenLine
Zaloguj się
Marcin Sysa

Marcin Sysa stock control,
Orange

Temat: Makro - kopiowanie wybranych wierszy

Witam,

Jestem nowy na tym forum wiec prosze o wyrozumialosc i z gory przepraszam za powstale bledy czy uzywanie malo branzowych sformulowan. Pracuje nad automatyzacja pewnego raportu na ktory trace mnostwo czasu kazdego dnia. W akruszu excela jest np 1000 wierszy - np nazwiska i dane pracownikow. W jednej z kolumn znajduje sie jaks zmienna jak np przynaleznosc do dzialu. Prubuje stworzyc makro ktoro by kopiowalo wszystkie wiersze na podstawie zmiennej z jednej kolumny D, przy czym liczba zmiennych tez sie zmienia. Czyli np. dzisiaj mam 5 zmiennych wiec chcialbym by makro stworzylo 5 nowych skoroszytow w tym samym pliku po 200 wierszy. Kazdego dnia ilosc wierszy i ilosc zmiennych jest inna. Bede wdzieczny za wskazowki bo dopiero stawiam pierwsze kroki w VB.

Pozdrawiam
Marcin
Link do wypowiedziLink
Monika M.

Monika M. PROGRAMISTA VBA,
Excel, Access,
Outlook, Word -
SZKOLENIA

Temat: Makro - kopiowanie wybranych wierszy

Zastanawiam się o co dokładnie chodzi. Proszę mnie poprawić, jeśli źle rozumiem.
Czy chodzi o to, aby wyłuskać rekordy (wiersze), które spełniają jakieś warunki (określone wartości w określonych kolumnach) i skopiować je do nowego arkusza, czy skoroszytu?
Np. mamy dane pracowników z różnych oddziałów w Polsce i chcemy skopiować dane tylko tych pracowników, którzy mieszkają w Krakowie, są z działu sprzedaży i np. mają mniej niż 30 lat?

To teraz kwestia tych zmiennych, tzn. od czego one zależą, od czego zależy ich ilość?
Pytanie też, na ile potrzebna jest automatyzacja (makro) i czy np. nie wystarczyłoby używać autofiltra albo filtra zaawansowanego?
Jeśli ilość kolumn jest stała, to może należałoby przeznaczyć gdzieś komórki, a może zrobić UserForma z polami tekstowymi - gdzie wpisywane byłyby kryteria tylko do tych, które będą brane pod uwagę, a pozostałe pozostawiamy puste?
No i jeszcze skąd bierzemy wartości dla kryteriów, tzn. czy wpisuje je użytkownik, czy jakoś inaczej.

Panie Marcinie, dużo łatwiej czytałoby się Pana post i nie trzeba by było zastanawiać się nad każdym słowem, gdyby używał Pan polskich znaków diakrytycznych. To naprawdę ułatwia zrozumienie tekstu, zwłaszcza że każdemu w tekście trafiają się literówki, a już taka mieszanka powoduje, że co chwilę trzeba wracać do jakiegoś wyrazu, aby zrozumieć wypowiedź.
Link do wypowiedziLink
Tomasz Gawęda

Tomasz Gawęda Kierownik Zakładu
Produkcyjnego

Temat: Makro - kopiowanie wybranych wierszy

Założenia: W skoroszycie istnieje tylko jeden arkusz o nazwie "Arkusz1" zawierający dane, kryterium wyboru znajduje się w kolumnie D. Skoroszyt jest zapisany!!!

Wklej poniższy kod, odpal makro "dzialaj" i zobacz co się stanie 
Option Explicit

Sub dzialaj()

Dim ark As Worksheet, temp As Worksheet

Dim i As Integer



Set ark = Sheets("Arkusz1")

For i = 1 To ark.Range("d65536").End(xlUp).Row

    If Not czyistnieje(ark.Cells(i, 4)) Then

        Sheets.Add

        Set temp = ActiveSheet

        temp.Name = ark.Cells(i, 4)

        temp.Move After:=Sheets(Sheets.Count)

        Call esql(ark.Cells(i, 4), temp.Name)

    End If

Next i



End Sub





Function esql(argument As String, arkusz As String)

Dim cn As Object, rs As Object

Dim nazwa As String, sqlstr As String

Dim ark As Worksheet

 

Set cn = CreateObject("ADODB.Connection")

Set rs = CreateObject("ADODB.Recordset")

  

nazwa = ActiveWorkbook.Path & Application.PathSeparator & ActiveWorkbook.Name

 

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _

      "Data Source=" & nazwa & ";" & _

      "Extended Properties=""Excel 8.0;HDR=No"""

    

sqlstr = "SELECT * FROM [Arkusz1$] WHERE F4 = '" & argument & "'"

Set rs = cn.Execute(sqlstr)

Set ark = ActiveWorkbook.Sheets(arkusz)



ark.Cells.ClearContents

ark.Range("a1").CopyFromRecordset rs

     

rs.Close

cn.Close



End Function



Function czyistnieje(nazwa As String) As Boolean

Dim ark As Worksheet

czyistnieje = False

For Each ark In ThisWorkbook.Worksheets

    If ark.Name = nazwa Then czyistnieje = True

Next ark

End Function
Tomasz Gawęda edytował(a) ten post dnia 20.08.10 o godzinie 13:39
Link do wypowiedziLink
Marcin Sysa

Marcin Sysa stock control,
Orange

Temat: Makro - kopiowanie wybranych wierszy

Makro dziala niemal takl jakbym sobie tego zyczyl. Wielkie podziekowania dla Tomasza. Co prawda jest tworzony arkusz "Item" ktory jest w tym miejscu zbedny, ale moze sam sobie juz z tym poradze. Dane sa kopiowane na podstawie zadanego kryterium, ale nie kopiowane sa oryginalne formaty kolumn.
Kolejne pytanie jest zwiazane z nazwa nowo powstajacych skoroszytow. Jak sprawic by nzwa kazdego skoroszytu miala numer kolejny zaczynajacy sie od 1 i majaca wartosc taka jak ilosc linii w akruszu, czyli np. arkusz pierwszy 1x250 (co oznacza 250 lini), nastepny skoroszyt 2x350 (czyli 350 wierszy) itd....

Jeszcze raz wielkie dzieki Tomasz
Link do wypowiedziLink
Marcin Sysa

Marcin Sysa stock control,
Orange

Temat: Makro - kopiowanie wybranych wierszy

Prosze pominac ta kwestie dotyczaca arkusza "Item" w moim wczesniejszym poscie. Wszystko dziala tak jak mialo dzialac. Zapomnialem wspomniec ze jest pewien naglowek w tym podstawowym arkuszu (wlasnie Item w kolumnie D) i stad na pierszej pozycji wzial sie taki arkusz. Gdyby piersze 3 wiersze nie byly brane pod uwage, bo sa naglowkiem to wszystko bylo by super.
To takie sprostowanie. Nie mialem czasu by dokladnie sprawdzic i przeczytac algorytm.
Link do wypowiedziLink
Tomasz Gawęda

Tomasz Gawęda Kierownik Zakładu
Produkcyjnego

Temat: Makro - kopiowanie wybranych wierszy

Nowa lepsza funkcja ;) "dzialaj". Podmień ją a powinna zrobić to co chcesz. 
Sub dzialaj()

Dim ark As Worksheet, temp As Worksheet

Dim i As Integer



Application.ScreenUpdating = False



Set ark = Sheets("Arkusz1")

For i = 4 To ark.Range("d65536").End(xlUp).Row

    If Not czyistnieje(ark.Cells(i, 4)) Then

        Sheets.Add

        Set temp = ActiveSheet

        temp.Move After:=Sheets(Sheets.Count)

        temp.Name = ark.Cells(i, 4)

        Call esql(ark.Cells(i, 4), temp.Name)

    End If

Next i



For i = 2 To Sheets.Count

    Sheets(i).Name = i - 1 & "x" & Sheets(i).Range("a65536").End(xlUp).Row & "_" & Sheets(i).Name

    ark.Select

    Rows("4:4").Select

    Selection.Copy

    Sheets(i).Select

    Rows("1:" & Sheets(i).Range("a65536").End(xlUp).Row).Select

    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _

        SkipBlanks:=False, Transpose:=False

    Application.CutCopyMode = False

    Sheets(i).Range("a1").Select

Next i



Application.ScreenUpdating = True



End Sub
Link do wypowiedziLink
Tomasz Karowski

Tomasz Karowski .NET contractor
providing
programming services

Temat: Makro - kopiowanie wybranych wierszy

witam,
potrzebuję podobnej metody, która na podstawie wartości z jednej kolumny kopiuje odpowiednie wiersze do nowych arkuszy.
W moim przypadku chodzi o kolumnę M więc domyślam się, że 4 muszę zamienić na 13.
Problemem jest dla mnie to, że po przekopiowaniu tego kodu mam błąd w linijce
Selection.PasteSpecial..... (2 linijki)

a drugi w cn.Open .... (3 linijki)

i jeszcze chciałbym zrobić, żeby nazwy arkuszy były brane z tej kolumny tj. jak w tej kolumnie mam np. 2 różne wartości AA i BB to chcę, żeby stworzył dwa nowe arkusze o nazwach AA i BB i do każdej przekopiował odpowiednie wiersze

byłbym bardzo wdzięczny za pomoc

EDIT:
udało mi się ogarnąć większość problemów jednak pozostało mi jeszcze kopiowanie nagłówka (scalone 2 pierwsze wiersze) do każdego nowego arkusza no i jak sprawić, żeby makro odpalało się automatycznie po otwarciu excelaTomasz Karowski edytował(a) ten post dnia 30.09.10 o godzinie 11:37
Link do wypowiedziLink
Tomasz Gawęda

Tomasz Gawęda Kierownik Zakładu
Produkcyjnego

Temat: Makro - kopiowanie wybranych wierszy

błąd w linijce
Selection.PasteSpecial..... (2 linijki)

To znaczy, że coś nie tak z przenoszeniem formatowania, może masz scalone komórki?
a drugi w cn.Open .... (3 linijki)

Zwróć proszę uwagę na ścieżkę dostępu do pliku. To makro operuje w ramach jednego skoroszytu, na zapisanym pliku, pobera dane z Arkusz1. Tak jest u ciebie?
i jeszcze chciałbym zrobić, żeby nazwy arkuszy były brane z tej kolumny tj. jak w tej kolumnie mam np. 2 różne wartości AA i BB to chcę, żeby stworzył dwa nowe arkusze o nazwach AA i BB i do każdej przekopiował odpowiednie wiersze

Sheets(i).Name za to odpowiada.
Link do wypowiedziLink
Tomasz Karowski

Tomasz Karowski .NET contractor
providing
programming services

Temat: Makro - kopiowanie wybranych wierszy

dzięki za pomoc prawie wszystko jest ok. Jak zedytowałem w poprzednim poście (nie widziałem jeszcze Twojego nowego) problemem jest jeszcze, żeby do każdego nowo utworzonego arkusza kopiował się także nagłówek (tj. 2 pierwsze wiersze scalone). Są to nagłówki kolumn (najlepiej jakby z właściwościami tj. nagłówki mają niebieskie tło.

Ostatnia drobiazg to jak sprawić, żeby makro odpalało się automatycznie przy otwieraniu pliku
Link do wypowiedziLink
Tomasz Gawęda

Tomasz Gawęda Kierownik Zakładu
Produkcyjnego

Temat: Makro - kopiowanie wybranych wierszy

A coś takiego w pętli po wszystkich arkuszach 
Sheets("Arkusz1").Select

Rows("1:2").Select

Selection.Copy

Sheets(id_lub_nazwa).Select

Rows("1:1").Select

Selection.Insert Shift:=xlDown


Można się jeszcze zastanowić nad tym czy zamiast Sheets.Add nie zrobić 
Sheets("Arkusz1").Copy After:=Sheets(ostatni_arkusz)
i wyczyścić poniżej nagłówka.

Automatyczne uruchamianie (w ThisWorkbook) 
Private Sub Workbook_Open()

nazwa_makra_jakie_uruchomic

End Sub
Link do wypowiedziLink
Tomasz Karowski

Tomasz Karowski .NET contractor
providing
programming services

Temat: Makro - kopiowanie wybranych wierszy

dzięki za pomoc wszystko prawie dobrze tj. nie scala mi tych wierszy, tzn. w pierwszym wierszu są nazwy kolumn, a drugi jest pusty. I ostatni drobiazg czy da się kopiować także kolor tła albo inne właściwości?

EDIT:
może jeszcze taka drobna pierdoła jak dopasowanie szerokości kolumny do długości tesktu ?Tomasz Karowski edytował(a) ten post dnia 30.09.10 o godzinie 12:15
Link do wypowiedziLink
Tomasz Gawęda

Tomasz Gawęda Kierownik Zakładu
Produkcyjnego

Temat: Makro - kopiowanie wybranych wierszy

I ostatni drobiazg czy da się kopiować także kolor tła albo inne właściwości?

Paste:=xlPasteFormats działa jak malarz formatów, więc kopiuje kolor tła i inne właściwości. Jeżeli chcesz to można odczytać w komórce np. kolor tła 
Cells(y, x).Interior.Color

może jeszcze taka drobna pierdoła jak dopasowanie szerokości kolumny do długości tesktu ?

Columns(numer_kolumny).AutoFit
Tomasz Gawęda edytował(a) ten post dnia 30.09.10 o godzinie 12:57
Link do wypowiedziLink
Tomasz Karowski

Tomasz Karowski .NET contractor
providing
programming services

Temat: Makro - kopiowanie wybranych wierszy

niezbyt to dział, tzn. jak mam to
Selection.Insert Shift:=xlDown
i chcę dorzuć do tego Paste:=xlPaste... to nie działa
Link do wypowiedziLink
Tomasz Gawęda

Tomasz Gawęda Kierownik Zakładu
Produkcyjnego

Temat: Makro - kopiowanie wybranych wierszy

Tego nie da się zawrzeć w jednej linii. Jeżeli kopiujesz wiersze nagłówkowe to kopiujesz je z formatowaniem więc po co jeszcze chcesz kopiować formaty?
Link do wypowiedziLink
Tomasz Karowski

Tomasz Karowski .NET contractor
providing
programming services

Temat: Makro - kopiowanie wybranych wierszy

chciałbym, żeby wyglądały tak samo jak na arkuszu, z którego są kopiowane. Czyli, że pierwszy i drugi wiersz w kolumnie jest scalony, a tło jest niebieskie. Obecnie przy tej metodzie kopiuje, ale wiersze nie są scalone no i brak tła
Link do wypowiedziLink
Tomasz Gawęda

Tomasz Gawęda Kierownik Zakładu
Produkcyjnego

Temat: Makro - kopiowanie wybranych wierszy

Nie rób Sheets.Add tylko skopiuj arkusz "źródłowy" tworząc z niego "wzorzec" i wyczyść wszytsko poniżej nagłówka, opisałem to wyżej.
Link do wypowiedziLink
Tomasz Karowski

Tomasz Karowski .NET contractor
providing
programming services

Temat: Makro - kopiowanie wybranych wierszy

nie wychodzi mi to,
zamieniłem Sheets.Add na Sheets("Arkusz1").Copy After:=Sheets(ostatni_arkusz)

ostatni_arkusz mam podać Sheets.Count ?

poza tym nie wiem jak mam usunąć zawartość poniżej
Link do wypowiedziLink
Tomasz Gawęda

Tomasz Gawęda Kierownik Zakładu
Produkcyjnego

Temat: Makro - kopiowanie wybranych wierszy

W pętli dodającej arkusze 
Sheets("Arkusz1").Copy After:=Sheets(Sheets.Count)

Set temp = ActiveSheet

temp.Name = ark.Cells(i, 4)

temp.Range("3:65536").ClearContents
Link do wypowiedziLink
Tomasz Karowski

Tomasz Karowski .NET contractor
providing
programming services

Temat: Makro - kopiowanie wybranych wierszy

Sub dzialaj()

(..)



Set ark = Sheets("lista_razem")



For i = 3 To ark.Range("d65536").End(xlUp).Row



    If Not czyistnieje(ark.Cells(i, 24)) Then

        Sheets("lista_razem").Copy After:=Sheets(Sheets.Count)

        Set temp = ActiveSheet     

        temp.Range("3:65536").ClearContents

        temp.Move After:=Sheets(Sheets.Count)

        temp.Name = ark.Cells(i, 24)

        Call esql(ark.Cells(i, 24), temp.Name)

    End If



Next i



For i = 2 To Sheets.Count - 1



    'Sheets("lista_razem").Select

    'Rows("1:2").Select

    'Selection.Copy

    'Sheets(i).Select

    'Rows("1:1").Select

    'Selection.Insert Shift:=xlDown



    ark.Select

    Rows("3:24").Select

    Selection.Copy

    Sheets(i).Select

    Rows("1:" & Sheets(i).Range("a65536").End(xlUp).Row).Select

    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False



    Application.CutCopyMode = False



    Sheets(i).Range("a3").Select



Next i



For i = 2 To Sheets.Count - 1

    Sheets(i).Select

    For j = 1 To Columns.Count

        Columns(j).AutoFit

    Next j

Next i



For i = 1 To Sheets.Count - 1

    Sheets(i).Select

    Columns(24).Select

    Selection.Delete

Next i



Application.ScreenUpdating = True





End Sub





Function esql(argument As String, arkusz As String)

(..)

 

sqlstr = "SELECT * FROM [lista_razem$] WHERE F24 = '" & argument & "'"



Set rs = cn.Execute(sqlstr)



Set ark = ActiveWorkbook.Sheets(arkusz)





ark.Cells.ClearContents



ark.Range("a3").CopyFromRecordset rs

     

(..)


takie coś mam i gdy kod w drugiej pętli na początku jest wykomentowany to nie działa. Gdy odkomentowany to w pierwszych dwóch wierszach mam nagłówki, ale ostylowanie (tj. kolorystyka niebieska itd) jest w 3-4 wierszu. I w tym przypadku kolorystyka jest tylko na 3 i kolejnych arkuszach (tj. na bazowym jest od początku, później na pierwszym utworzonym nie ma i dopiero na kolejnych)

słowem wyjaśnienia, obecnie jest to filtrowane na podstawie zawartości 24 kolumny, która na końcu jest usuwana

chodzi mi głównie o te wartości typu "a3" czy takie powinny być np. funkcji esql itd. bo chyba w tym leży problemTomasz Karowski edytował(a) ten post dnia 30.09.10 o godzinie 15:00
Link do wypowiedziLink
Tomasz Gawęda

Tomasz Gawęda Kierownik Zakładu
Produkcyjnego

Temat: Makro - kopiowanie wybranych wierszy

Uwagi:

pierwsza pętla - niepotrzebnie robisz 
temp.Move After:=Sheets(Sheets.Count)
ponieważ 
Sheets("lista_razem").Copy After:=Sheets(Sheets.Count)
już umieszcza arkusz jako ostatni i możesz zastosować tu 
ark.Copy After:=Sheets(Sheets.Count)


druga pętla - wygląda jakbyś chciał przenieść formatowanie z wierszy od 3 do 24 na wiersze od 1 do ostatniego wypełnionego. To się będzie gryzło. Po co to robić jak wcześniej kopiowałeś arkusze z formatowaniem i je tylko wypełniasz danymi?

pętle z AutoFit i usuwaniem kolumny - dlaczego robisz to w zewnętrznych pętlach? Przez to spowalniasz działanie. Przecież możesz to wywoływać po zakończeniu działania funkcji esql albo po przeniesieniu formatowania.

Wywołując 
Call esql(ark.Cells(i, 24), temp.Name)
uzyskasz recordset zawierający wszytskie pola (*) z arkusza lista_razem zawierające w kolumnie 24 podany przez ciebie argument. Wynik tego query zostanie wklejony do A3 (lewy górny róg).

Próbujesz dostosować na siłę kod do twojego układu zamiast go na nowo napisać, zapętlisz się przy bardziej rozbudowanych projektach.....Tomasz Gawęda edytował(a) ten post dnia 30.09.10 o godzinie 15:39
Link do wypowiedziLink
« Wróć do tematów
Odpowiedz

Podobne tematy


Następna dyskusja:

Makro - kopiowanie wybranyc...




Wyślij zaproszenie do
Anuluj