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

EXCEL - makro - kopiowanie zaw. kom. do innego pliku w pętli

28 Cze 2009 19:45 24170 14
  • Poziom 9  
    Witam,
    łamię sobie głowę jak napisać makro, aby kopiowało mi kolejno komórki z jednego pliku do innego.
    Otóż w pliku Zeszyt1 mam kolumnę cyfr A1:A100.
    W pliku Zeszyt2 mam w komórce D1 formulę przykładowo =C1*100.
    Potrzebuję utworzyć takie makro, które pobierało by kolejno wartości z Zeszytu1 kolumny A1:A100 i kopiowało do pliku Zeszyt2 komórka C1.
    Następnie pobierało wartość z pliku Zeszyt2 komórki D1 i kopiowało kolejno do pliku Zeszyt1 kolumna B1:B100.
    Przykładowo
    1-szy krok
    Kopiuj z Zesztyt1 A1, wklej wartość do Zesztyt 2 C1,
    Kopiuj z Zesztyt2 D1, wklej wartość do Zesztyt 1 B1,
    2-gi krok
    Kopiuj z Zesztyt1 A2, wklej wartość do Zesztyt 2 C1,
    Kopiuj z Zesztyt2 D1, wklej wartość do Zesztyt 1 B2,
    3-gi krok
    Kopiuj z Zesztyt1 A3, wklej wartość do Zesztyt 2 C1,
    Kopiuj z Zesztyt2 D1, wklej wartość do Zesztyt 1 B3,
    n-ty krok
    Kopiuj z Zesztyt1 An, wklej wartość do Zesztyt 2 C1,
    Kopiuj z Zesztyt2 D1, wklej wartość do Zesztyt 1 Bn,
    bez pętli moje makro dla 3 kroków wygląda tak:
    Sub Makro1()
    Range("A1").Select
    Selection.Copy
    Windows("Zeszyt2").Activate
    Range("C1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Range("D1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Zeszyt1").Activate
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Range("A2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Zeszyt2").Activate
    Range("C1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Range("D1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Zeszyt1").Activate
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Range("A3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Zeszyt2").Activate
    Range("C1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Range("D1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Zeszyt1").Activate
    Range("B3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    End Sub
    Jednak dla n operacji zapisałbym się na śmierć, więc chyba trzeba byłoby użyć tu pętli. Czy ktoś wie, jak napisać taką pętlę?
  • Moderator Programowanie
    Wypróbuj coś takiego
    Code:
    Sub kopiuj()
    
    Dim plik As Workbook
    Dim i As Long, pierwszyWiersz As Integer, ostatniWiersz As Long
    'jesli nie dalej niz wiersz Nr 32767 wystarczy As Integer

    pierwszyWiersz = 1
    ostatniWiersz = 100

    'jesli w tym samym katalogu
    Set plik = Workbooks.Open(Filename:=ThisWorkbook.Path & "\Zeszyt2.xls")
    'jesli nie, to sciezka dostepu i nazwa pliku
    'Set plik = Workbooks.Open(Filename:= "C:\TwojKatalog\Zeszyt2.xls")

    'zakladam, ze w pliku Zeszyt2 kopiujesz do/z Arkusz1
    For i = pierwszyWiersz To ostatniWiersz
        plik.Sheets("Arkusz1").Range("C1") = ThisWorkbook.ActiveSheet.Range("A" & i)
        ThisWorkbook.ActiveSheet.Range("B" & i) = plik.Sheets("Arkusz1").Range("D1")
    Next

    plik.Close savechanges:=True
    Set plik = Nothing
    End Sub
  • Poziom 9  
    Niestety, nie bardzo mi oto chodziło.

    Otóż mam plik: Zeszyt2, w którym podaje się dane wejściowe w jednej komórce, następnie wykonywane jest w tym pliku skomplikowane działanie i wynik wyświetlany jest w drugiej komórce.
    Takich danych wejściowych mam dużo, ale wynik jest wykonywany tylko z danymi z jednej komórki i podawany też tylko w jednej.
    Działanie jest wykonywane tylko dla jednej komórki.

    Więc wymyśliłem sobie, że napiszę makro.
    W pliku Zeszyt1 będę miał całą kolumnę danych wejściowych.
    Makro po kolei będzie mi kopiować dane (wyłącznie wartości) z pliku Zeszyt1 (z A1, potem z A2, A3 itd) do pliku Zeszyt2, tam wykonane będzie działanie i wynik z konkretnej komórki będzie z powrotem kopiowany do pliku Zeszyt1 z danymi, obok użytej komórki z daną wejściową (do B1, potem do B2, B3 itd).

    A więc tak:
    KROK1
    - kopiuję wartość (dane wejściowe) z pliku Zeszyt1 komórki A1 do pliku Zeszyt 2 (w konkretne miejsce np. C1),
    - w pliku Zeszyt2 wykonywane jest określone działanie na podstawie formuły, która już tam jest w tym pliku,
    - kopiuje wynik działania z pliku Zeszyt2 (z określonej komórki np. D1) do pliku Zeszyt1 do komórki B1, obok wartości wyjściowej.
    KROK2
    - kopiuję następną wartość (dane wejściowe) z pliku Zeszyt1 komórki A2 do pliku Zeszyt 2 (w konkretne te same miejsce C1),
    - w pliku Zeszyt2 znowu wykonywane jest określone działanie na podstawie formuły, która już tam jest w tym pliku,
    - kopiuje wynik działania z pliku Zeszyt2 (z określonej tej samej komórki np. D1) do pliku Zeszyt1 do następnej komórki B2, obok odpowiadającej jej wartości wyjściowej.
    KROK 3, 4 ... i n analogicznie

    Chodzi oto, aby komórki w pliku Zeszyt1 były kopiowane z i do kolejnych komórek następujących po sobie w tej samej kolumnie, a w pliku Zeszyt2, w którym wykonywane jest działanie główne, komórki były kopiowane z i do tych samych konkretnych komórek.
  • Pomocny post
    Moderator Programowanie
    Cytat:
    następnie wykonywane jest w tym pliku skomplikowane działanie
    Na pewno można je z powodzeniem wykonać w VBA. Z drugiej strony: Dlaczego "w kolumnie obok" nie użyjesz tej formuły z "Zeszyt2"? Wydaje mi się, że zamiast opisywać zawartość arkuszy lepiej (wygodniej dla wszystkich) wrzucić plik z przykładem w postaci załącznika na forum :) Szybciej i precyzyjniej otrzymasz pomoc.
  • Poziom 9  
    Przepraszam, Twoja propozycja makra jest idealna! Nie zadziałało mi, ponieważ w docelowym pliku obliczeniowym arkusz został inaczej nazwany i nie zwróciłem na to uwagi. Makro działa świetnie, ale czad! :D
    Jakby ktoś miał jeszcze jakieś makro na szybsze kojarzenie, to chyba też by mi się przydało :D
  • Pomocny post
    Poziom 40  
    :arrow: Do autora: Dobrze podstawiłeś to makro? W załączeniu przykład z działającym makrem kolegi adamas_nt Poprawiłem tylko to, że nie liczy dla 100 wierszy tylko dla wszystkich wierszy w kolumnie A zeszytu1.

    Dodane po czasie
    -----------------------------
    Zmieniłeś treść wiadomości więc moja uwaga nie ma już uzasadnienia, niemniej pozostawiam przykład - a nuż komuś się przyda.
  • Poziom 9  
    adamas_nt napisał:
    Wypróbuj coś takiego
    Code:
    Sub kopiuj()
    
    Dim plik As Workbook
    Dim i As Long, pierwszyWiersz As Integer, ostatniWiersz As Long
    'jesli nie dalej niz wiersz Nr 32767 wystarczy As Integer

    pierwszyWiersz = 1
    ostatniWiersz = 100

    'jesli w tym samym katalogu
    Set plik = Workbooks.Open(Filename:=ThisWorkbook.Path & "\Zeszyt2.xls")
    'jesli nie, to sciezka dostepu i nazwa pliku
    'Set plik = Workbooks.Open(Filename:= "C:\TwojKatalog\Zeszyt2.xls")

    'zakladam, ze w pliku Zeszyt2 kopiujesz do/z Arkusz1
    For i = pierwszyWiersz To ostatniWiersz
        plik.Sheets("Arkusz1").Range("C1") = ThisWorkbook.ActiveSheet.Range("A" & i)
        ThisWorkbook.ActiveSheet.Range("B" & i) = plik.Sheets("Arkusz1").Range("D1")
    Next

    plik.Close savechanges:=True
    Set plik = Nothing
    End Sub


    Chciałbym zapytać jeszcze, czy dałoby radę wstawić warunek do pętli, taki, że np. gdyby Range("A" & i) =0 (komórka An miała wartość zerową) to makro kończyłoby swoje działanie?
  • Pomocny post
    Poziom 40  
    Właśnie to pozwoliłem sobie zmienić w przesłanym przykładzie w makrze kolegi adamas_nt
    Wpisz zamiast
    Code:
    ostatniWiersz = 100

    to
    Code:
    ostatniWiersz = Sheets("Arkusz1").Cells(pierwszyWiersz, 1).End(xlDown).Row


    Wtedy makro samo policzy ile jest wierszy i będzie się wykonywało tylko do ostatniego wiersza. Warunek dane w kolumnie A muszą byc ciągłe (bez pustych komórek) pusta (nie równa 0) komórka przerywa liczenie wierszy. Jezeli ma byc konkretnie 0 to pisz zaraz coś się wymyśli.

    Lub zmień pętle z prostej (For) na warunkową (np. Do Until)
    Code:
    Sub kopiuj()
    
    Dim plik As Workbook
    Dim i As Long

    i = 1 'czyli pierwszy wiersz

    Set plik = Workbooks.Open(Filename:=ThisWorkbook.Path & "\Zeszyt2.xls")

    Do Until ThisWorkbook.ActiveSheet.Range("A" & i) = ""
        plik.Sheets("Arkusz1").Range("C1") = ThisWorkbook.ActiveSheet.Range("A" & i)
        ThisWorkbook.ActiveSheet.Range("B" & i) = plik.Sheets("Arkusz1").Range("D1")
        i = i + 1
    Loop

    plik.Close savechanges:=True
    Set plik = Nothing
    End Sub



    Możesz tez dodać chwilowe wyłączenie odświeżania wtedy nie będzie ci skakał obraz pomiędzy arkuszami.
    Wstaw w linię przed wpisem dotyczącym pierwszego wiersza = 1
    Code:
    Application.ScreenUpdating = False


    A przed End Sub wpisz
    Code:
    Application.ScreenUpdating = True


    I nie będzie "skakanki".
  • Pomocny post
    Moderator Programowanie
    Np
    Code:
    For i = pierwszyWiersz To ostatniWiersz
    
        If ThisWorkbook.ActiveSheet.Range("A" & i) <> 0 Then
            plik.Sheets("Arkusz1").Range("C1") = ThisWorkbook.ActiveSheet.Range("A" & i)
            ThisWorkbook.ActiveSheet.Range("B" & i) = plik.Sheets("Arkusz1").Range("D1")
        Else
            Exit For
        End If
    Next

    Makro przerwie działanie na pierwszej napotkanej wartości=0
    Spróbuj też z rozwiązaniem sugerowanym przez kolegę marek003.
  • Poziom 9  
    Szok, że jest aż tyle możliwości!
    Przetestuję je wszystkie, na pewno nie raz mi się przydadzą :D
    Dzięki i pozdrawiam.
  • Poziom 9  
    A jak zrobić coś takiego:

    Mam plik z danymi. Jedna kolumna w tym pliku to daty. Potrzebuje skopiować do drugiego pliku wszystkie wiersze, które w komórce z datą zawierają szukaną datę (szukana data jest zapisana w pliku2).

    Zrobiłem taki warunek ale nie działa tak jakbym chciał
    Code:
    If plik.Sheets("Arkusz1").Range("AA4" & i) <> ThisWorkbook.ActiveSheet.Range("I1") Then
    
        ThisWorkbook.ActiveSheet.Range("B1" & i) = plik.Sheets("Arkusz1").Range("E4" & i)
  • Moderator Programowanie
    :arrow: tang0

    1. Z pewnością zauważyłeś, że warunkiem jest nierówność.
    2. Do kopiowania używa się instrukcji Copy
    3. Jeśli cały wiersz to Rows(i)

    Mały przykład kopiowania wierszy pomiędzy arkuszami
    Code:
    For i = 1 To 3 'dla 3 wierszy
    
      Sheets("Arkusz1").Rows(i).Copy Sheets("Arkusz2").Rows(i)
    Next

    Z resztą sobie na pewno poradzisz
  • Poziom 1  
    Witam wszystkich.
    Mam nadzieje, że zadam pytanie w temacie, otóż szukam rozwiązania aby w pliku wynikowym wyświetlał mi wartość ze wszystkich plików z danego katalogu. Wszystkie te pliku mają wynik w tej samej komórce. Byłbym wdzięczny za w miarę jasną podpowiedź jako, że zielony jestem.
  • Moderator Programowanie
    :arrow: TP_D
    Nieee, to inny temat. Załóż nowy. Zwrócę tylko uwagę (może na coś Cię to naprowadzi), że funkcję: Dir i instrukcję: Set można zastosować wewnątrz pętli...
  • Poziom 9  
    Dzięki za wszystkie wskazówki (bardzo pomogły).
    Pętla działa już jak powinna:
    Code:
    For i = pierwszyWiersz To ostatniWiersz
    
        If Sheets("Arkusz2").Range("A1") = Sheets("Arkusz1").Range("Q" & i) Then
            licznik = licznik + 1
            Sheets("Arkusz1").Range(Range("D" & i), Range("M" & i)).Copy Sheets("Arkusz2").Rows(licznik)
        End If
    Next


    Teraz gdy znajduje pasujący element kopiuje fragment danego wiersza do drugiego arkusza i wkleja go. Gdy znajdzie kolejny wkleja go wiersz niżej.
    Zostało mi jeszcze do zrobienia aktywacja makra po naciśnięciu zakładki Arkusz2.
    (Warunek mam taki że wszystko odbywa się prawie że "bezdotykowo" )
    :D

    @ up
    ...już mam :) automatyzacja makra