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
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ź.
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
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
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.
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
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
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.
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
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
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
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
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
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?
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
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.
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
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
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
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

Następna dyskusja:

Makro - kopiowanie wybranyc...




Wyślij zaproszenie do