Elektroda.pl
Elektroda.pl
X
Proszę, dodaj wyjątek www.elektroda.pl do Adblock.
Dzięki temu, że oglądasz reklamy, wspierasz portal i użytkowników.

vba/makra - kopiowanie wybranych wierszy do nowych arkuszy

maryluu2014 07 Gru 2016 12:18 786 16
  • #1 07 Gru 2016 12:18
    maryluu2014
    Poziom 6  

    Witam
    Kolejny raz bardzo proszę o pomoc.
    Potrzebuje kodu, który na podstawie wartości z kolumny H kopiuje dany wiersz do innych arkuszy. Jestem raczkująca w tej dziedzinie, ale napisałam bardzo prosty kod, który działa , ale nie tak jak bym chciała. Kopiuje on wybrane wiersze, ale chciałabym by zostały wklejane w wybranym arkuszu w wierszu czwartym, a "on" wstawia tak jak w bazowym akruszu.
    Chciałam też , by jeśli znajdzie wybraną wartość w tabeli w kolumnie H to otwierał nowy arkusz o takiej samej nazwie jak wyszukana liczba, ale niestety nie potrafię tego napisać- napisałam prosty kod który miał otwierać nowe arkusze o konkretnej nazwie:

    Kod: vbscript
    Zaloguj się, aby zobaczyć kod

    ale gdy wkleiłam to do mojego kodu - nie zadziałało.
    Mój kod:
    Kod: vbscript
    Zaloguj się, aby zobaczyć kod

    Niestety nie wiem jaka będzie wartość końcowa w kolumnie H- przypuszczam, że nie więcej niż 20.
    Chciałabym by kopiował również wiersze do kolumny I- w pozostałych kolumnach mam kształty do edycji innych arkuszy i one tez mi się kopiują niestety :/
    Za jakiekolwiek wskazówki będę bardzo bardzo wdzięczna

    0 16
  • #2 07 Gru 2016 13:05
    JRV
    Specjalista - VBA, Excel

    Kod: vb
    Zaloguj się, aby zobaczyć kod

    0
  • #3 07 Gru 2016 13:14
    maryluu2014
    Poziom 6  

    Dziękuję za poświeczony czas.
    Pojawia się błąd przy:
    ActiveSheet.Name = ark

    0
  • Pomocny post
    #4 07 Gru 2016 13:24
    JRV
    Specjalista - VBA, Excel

    W kolumnie H jest wartosc?

    Dodano po 7 [minuty]:

    Zamiast
    ark = xxx.Cells(x, "H")
    Wpisz
    ark = xxx.Cells(x, "H").Text

    0
  • #5 07 Gru 2016 13:53
    maryluu2014
    Poziom 6  

    Tak w kolumnie H jest zawsze liczba.
    Kod jest super. Nie wiem czy jestem w stanie go samodzielnie zrozumieć.
    Dziękuję bardzo bardzo:)
    Jeszcze jedno pytanie, w jaki sposób zmienić kod by kopiował zawsze też nagłówki tabelki oraz aby kopiował do arkuszy od 4 wiersza.?

    0
  • Pomocny post
    #6 07 Gru 2016 14:01
    JRV
    Specjalista - VBA, Excel

    1. Ile wierszy w naglowkoch(trzy)?
    2. Zamiast
    wrsz = Application.CountA(yyy.Columns(1)) + 1
    wpisz
    wrsz = yyy.Cells(Rows.count, 1).End(xlUp).Row +1
    If wrsz < 4 Then wrsz = 4

    0
  • #7 07 Gru 2016 19:32
    maryluu2014
    Poziom 6  

    jeden wiersz w nagłówku:
    Load Number ASN Purchase Order Number Part Number Service Level Destination City
    tak jak w pliku

    Dodano po 5 [minuty]:

    jeszcze raz dziękuję za bezcenną pomoc

    0
  • #8 07 Gru 2016 19:35
    JRV
    Specjalista - VBA, Excel

    maryluu2014 napisał:
    jeden wiersz w nagłówku

    maryluu2014 napisał:
    aby kopiował do arkuszy od 4 wiersza

    Jaky sens?
    Po
    ActiveSheet.Name = ark
    Dodaj
    xxx.Rows(1).Copy yyy.Rows( 1)

    0
  • #9 07 Gru 2016 20:23
    maryluu2014
    Poziom 6  

    Masz rację, zmieniłam na kopiowanie od 2 wiersza.
    Docelowo w kolumnie I w pliku bazowym będą wagi, w jaki sposób mogę podsumować kolumnę I w każdym aktywnym arkuszu- od arkusza o nazwie"1" do ostatniego?

    0
  • #10 09 Gru 2016 12:04
    maryluu2014
    Poziom 6  

    witam
    Mam kod do wyznaczania sumy, gdyby kos jeszcze mógł mi pomóc go zapętlić, by działał na wszystkich arkuszach a nie pojedynczo.
    Sub SumaC()
    Dim ws As Worksheet
    For Each ws In Worksheets
    If ws.Name <> "RYDER" Or ws.Name <> "PORTAL" Then
    Cells(2, 1).Value = "suma"
    Range("B2") = "=SUM(I4:I50)"
    End If
    Next ws
    End Sub
    Albo chociaż wskazał jakie błędy popełniam

    0
  • Pomocny post
    #11 09 Gru 2016 12:53
    clubs
    Poziom 29  

    Witam

    Kod: vbnet
    Zaloguj się, aby zobaczyć kod

    0
  • #12 09 Gru 2016 13:11
    maryluu2014
    Poziom 6  

    Bardzo dziękuję :)

    0
  • #13 12 Gru 2016 11:46
    maryluu2014
    Poziom 6  

    W związku z tym plikiem mam jeszcze jeden problem. Mam tabelkę w której są 3 kolumny, w pierwszej jest nr kartonu, w drugiej najdłuższy wymiar, a w trzeciej waga kartonu.
    Numery boxów odpowiadają numerom arkuszy( ich ilość w zależności od danych będzie różna).
    Chciałam napisać marko które numer z pierwszej kolumny połączy z tym samym arkuszem i skopiuje w konkretną komórkę w arkuszach wagę kartonów.
    mój kod:

    Sub xxx()
    Dim i&, ws As Worksheet, zzz As Worksheet, yyy As Worksheet

    last_row1 = zzz.Cells(zzz.Rows.Count, "K").End(xlUp).Row
    For i = 2 To last_row1
    ark1 = zzz.Cells(Z, "K").Value
    For Each ws In Worksheets

    If ws.Name = ark1 Then
    Set yyy = ThisWorkbook.Sheets(ark1)
    Exit For
    End If
    Next
    If yyy = ark1 Then
    zzz.Cells(i, 12).Copy yyy.Range("A1")

    End If
    Next i
    End Sub

    Bardzo proszę o sprawdzenie kodu, być może sam błąd jest niewielki. Będę bardzo wdzięczna.

    0
  • Pomocny post
    #14 13 Gru 2016 11:11
    clubs
    Poziom 29  

    Witam
    Dla załączonego wyżej przykładu

    Kod: vbnet
    Zaloguj się, aby zobaczyć kod

    0
  • #15 13 Gru 2016 15:49
    maryluu2014
    Poziom 6  

    Niestety nie działa:/.

    Dodano po 5 [minuty]:

    Przepraszam, wszystko ok. Działa super :). Dziękuję bardzo.
    Proszę jeszcze o jedną rzecz. Mam kod- od kolegi z forum.
    Potrzebowałabym zmienić go tak aby kopiował tylko kolumny od 5 do 9 , a nie całość
    Sub kopiaBOX()
    Dim x&, y&, last_row&, xxx As Worksheet, yyy As Worksheet
    Set xxx = Sheets("baza")
    last_row = xxx.Cells(xxx.Rows.Count, "H").End(xlUp).Row
    Application.ScreenUpdating = False
    For x = 2 To last_row
    Set yyy = Nothing
    ark = xxx.Cells(x, "H").Text
    For Each sh In ThisWorkbook.Sheets
    If sh.Name = ark Then
    Set yyy = ThisWorkbook.Sheets(ark)
    Exit For
    End If
    Next
    If yyy Is Nothing Then
    Set yyy = Sheets.Add(After:=Sheets(Sheets.Count))
    ActiveSheet.Name = ark
    xxx.Rows(1).Copy yyy.Rows(3)
    End If
    wrsz = yyy.Cells(Rows.Count, 1).End(xlUp).Row + 1
    If wrsz < 4 Then wrsz = 4
    xxx.Cells(x, 1).Resize(1, 8).Copy yyy.Cells(wrsz, 1)
    Next x
    Application.ScreenUpdating = True
    End Sub

    oraz zmienić:
    xxx.Rows(1).Copy yyy.Rows(3)
    tak, bo kopiował nagłówki też od 5 do 9 kolumny

    0
  • Pomocny post
    #16 13 Gru 2016 15:57
    JRV
    Specjalista - VBA, Excel

    Zamiast

    Kod: vb
    Zaloguj się, aby zobaczyć kod

    Wpisz
    Kod: vb
    Zaloguj się, aby zobaczyć kod

    Naglowki
    xxx.Cells(1, 5).Resize(1, 5).Copy yyy.Cells(3, 1)

    0
  • #17 13 Gru 2016 15:59
    maryluu2014
    Poziom 6  

    Dziękuję bardzo

    0