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.

excel - kopiowanie wierszy i usuwanie diplikatów do arkusza

madx27 06 Maj 2010 19:24 4750 4
  • #1 06 Maj 2010 19:24
    madx27
    Poziom 2  

    Witam
    Czy ktoś miałby chwilkę i mógłby mi pomóc? (może być makro lub jeśli się da to funkcje z arkuszem pomocniczym).
    Mam problem z kopiowaniem wierszy i ich dublowaniem do gotowego arkusza.
    Mam skoroszyt, który zawiera 3 arkusze robocze: "Re_1", "Re_2" , "Re_3" oraz arkusz wynikowy "Wynik".
    Do "Re_1", "Re_2" , "Re_3" dopisywane są nowe wartości.
    Potrzebuje wyciągnąć wszystkie wiersze z "Re_1", "Re_2" , "Re_3" które będą odpowiadać konkretnej szukanej wartości z kolumny "A" (w przykładowym arkuszu 10867). Druga zależność - jeśli dane z kolumny "A" oraz "B" się powtórzą to ma nastąpić skopiowanie wiersza tylko z tego arkusza "Re_1", "Re_2" , "Re_3" który będzie miał dane w ostatniej kolumnie "F". Wyjątkiem będzie arkusz "Re_3" który może nie mieć żadnych danych w tej kolumnie.
    Chciałbym aby arkusz z wynikiem informował z którego arkusza został skopiowany, np w pierwszej kolumnie była nazwa arkusza "Re_1" lub "Re_2" lub "Re_3.
    W załączniku plik.xls aby załapać o co mi chodzi.

    Pod spodem przykład znaleziony w sieci, który chciałem wykorzystać, lecz gdy próbowałem dopasować "pod siebie" to wychodzą jakieś dziwolągi :(.
    Próbowałem skorzystać z tego makra, wyszukuje w kolumnie i kopiuje cały wiersz, lecz kopiuje ono tylko z jednego arkusza i nie sprawdza zależności z innych kolumn.

    Code:


        Sub SearchForString()

            Dim LSearchRow As Integer
            Dim LCopyToRow As Integer
            Dim LSearchValue As String

            On Error GoTo Err_Execute

            LSearchValue = InputBox("Please enter a value to search for.", "Enter value")

            'Start search in row 1
            LSearchRow = 1

            'Start copying data to row 1 in Sheet2 (row counter variable)
            LCopyToRow = 1

            While Len(Range("A" & CStr(LSearchRow)).Value) > 0

                'If value in column E = LSearchValue, copy entire row to Sheet2
                If Range("E" & CStr(LSearchRow)).Value = LSearchValue Then

                    'Select row in Sheet1 to copy
                    Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
                    Selection.Copy

                    'Paste row into Sheet2 in next row
                    Sheets("Sheet2").Select
                    Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
                    ActiveSheet.Paste

                    'Move counter to next row
                    LCopyToRow = LCopyToRow + 1

                    'Go back to Sheet1 to continue searching
                    Sheets("Sheet1").Select

                End If

                LSearchRow = LSearchRow + 1

            Wend

            'Position on cell A3
            Application.CutCopyMode = False
            Range("A3").Select

            MsgBox "All matching data has been copied."

            Exit Sub

        Err_Execute:
            MsgBox "An error occurred."

        End Sub

    Wielkie dzięki za pomoc.

    0 4
  • #2 07 Maj 2010 12:46
    ciubas
    Poziom 22  

    A powiedz mi nie łatwiej było by użyć narzędzia wbudowanego w excela: usuń duplikaty (jeżeli dane są niepotrzebne)

    Właściwe rozwiązanie do wszystkiego innego to: tabela przestawna. Myślę, że to rozwiązało by Twoje zagadnienie. I nie musisz programować, tylko poprzeciągać elementy.

    0
  • Pomocny post
    #3 07 Maj 2010 13:36
    marek003
    Poziom 40  

    Usuń duplikaty ani tabela przestawna tu się nie przyda bo dochodzi warunek że usuń gdy puste ale nie gdy puste w Re_3

    Stworzyłem w sumie proste makro (ono tylko tak wygląda)

    Pierwsza część kodu przepisuje wszystkie linie mające to samo zlecenie.
    Później następuje sortowanie.

    Następnie warunek sprawdza czy (w moim przypadku coś1) się powtarza jeżeli tak to sprawdza czy jest ostatnia dana (zamówienie) w pierwszym z badanych wierszy.
    Jak nie ma to usuwa wiersz jak jest to sprawdza drugi wiersz.
    Jak nie ma w drugim wierszu na końcu żadnej danej i nie jest to wiersz z Re_3 to usuwa.
    Cofa licznik pętli i znowu sprawdza kolejne dwa wiersze

    Jak wszystko "przepatrzy" zaznacza A1

    i ... koniec.

    Code:
    Sub wynik()
    
    a = Val(InputBox("Podaj zamówienie"))
    Cells.Select
    Selection.ClearContents

    y = 2
    x = 1

            Worksheets("Wynik2").Cells(1, 1).Value = "Arkusz"
            Worksheets("Wynik2").Cells(1, 2).Value = "Zamówienie"
            Worksheets("Wynik2").Cells(1, 3).Value = "coś1"
            Worksheets("Wynik2").Cells(1, 4).Value = "coś2"
            Worksheets("Wynik2").Cells(1, 5).Value = "coś3"
            Worksheets("Wynik2").Cells(1, 6).Value = "data"
            Worksheets("Wynik2").Cells(1, 7).Value = "wydanie"


    Do While Worksheets("Re_1").Cells(x, 1).Value <> ""
        If Worksheets("Re_1").Cells(x, 1).Value = a Then
            Worksheets("Wynik2").Cells(y, 1) = "Re_1"
            Worksheets("Wynik2").Cells(y, 2).Value = Worksheets("Re_1").Cells(x, 1).Value
            Worksheets("Wynik2").Cells(y, 3).Value = Worksheets("Re_1").Cells(x, 2).Value
            Worksheets("Wynik2").Cells(y, 4).Value = Worksheets("Re_1").Cells(x, 3).Value
            Worksheets("Wynik2").Cells(y, 5).Value = Worksheets("Re_1").Cells(x, 4).Value
            Worksheets("Wynik2").Cells(y, 6).Value = Worksheets("Re_1").Cells(x, 5).Value
            Worksheets("Wynik2").Cells(y, 7).Value = Worksheets("Re_1").Cells(x, 6).Value




            y = y + 1
        End If
    x = x + 1
    Loop

    x = 1
    Do While Worksheets("Re_2").Cells(x, 1).Value <> ""
        If Worksheets("Re_2").Cells(x, 1).Value = a Then
            Worksheets("Wynik2").Cells(y, 1).Value = "Re_2"
            Worksheets("Wynik2").Cells(y, 2).Value = Worksheets("Re_2").Cells(x, 1).Value
            Worksheets("Wynik2").Cells(y, 3).Value = Worksheets("Re_2").Cells(x, 2).Value
            Worksheets("Wynik2").Cells(y, 4).Value = Worksheets("Re_2").Cells(x, 3).Value
            Worksheets("Wynik2").Cells(y, 5).Value = Worksheets("Re_2").Cells(x, 4).Value
            Worksheets("Wynik2").Cells(y, 6).Value = Worksheets("Re_2").Cells(x, 5).Value
            Worksheets("Wynik2").Cells(y, 7).Value = Worksheets("Re_2").Cells(x, 6).Value
            y = y + 1
        End If
    x = x + 1
    Loop

    x = 1
    Do While Worksheets("Re_3").Cells(x, 1).Value <> ""
        If Worksheets("Re_3").Cells(x, 1).Value = a Then
            Worksheets("Wynik2").Cells(y, 1).Value = "Re_3"
            Worksheets("Wynik2").Cells(y, 2).Value = Worksheets("Re_3").Cells(x, 1).Value
            Worksheets("Wynik2").Cells(y, 3).Value = Worksheets("Re_3").Cells(x, 2).Value
            Worksheets("Wynik2").Cells(y, 4).Value = Worksheets("Re_3").Cells(x, 3).Value
            Worksheets("Wynik2").Cells(y, 5).Value = Worksheets("Re_3").Cells(x, 4).Value
            Worksheets("Wynik2").Cells(y, 6).Value = Worksheets("Re_3").Cells(x, 5).Value
            Worksheets("Wynik2").Cells(y, 7).Value = Worksheets("Re_3").Cells(x, 6).Value
            y = y + 1
        End If
    x = x + 1
    Loop

         Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("A1") _
            , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
            False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
            :=xlSortNormal



    x = 1
    Do While Worksheets("Wynik2").Cells(x, 3).Value <> ""
        If (Worksheets("Wynik2").Cells(x, 3).Value = Worksheets("Wynik2").Cells(x + 1, 3).Value) Then
               
            If Worksheets("Wynik2").Cells(x, 7).Value = "" Then
                Rows(x & ":" & x).Select
                Selection.Delete Shift:=xlUp
                x = x - 1
            Else
                If Worksheets("Wynik2").Cells(x + 1, 7).Value = "" And Worksheets("Wynik2").Cells(x + 1, 1).Value <> "Re_3" Then
                    Rows(x + 1 & ":" & x + 1).Select
                    Selection.Delete Shift:=xlUp
                    x = x - 1
                End If
            End If
        End If
       
           
    x = x + 1
    Loop

    Range("a1").Select

    End Sub

    0
  • #4 07 Maj 2010 23:44
    madx27
    Poziom 2  

    wow marek003
    wielkie dzięki, może i proste makro - ale dla mnie wielkie :)
    Mam jeszcze inny problem - czy ktoś potrafi to przerobić aby działało również na openoffice.
    Wyskakuje błąd: Błąd Uruchomieniowy Języka Basic. Nie ustawiono zmiennej obiektu. i zatrzymuje się na Cells.Select.
    Dzieki

    0
  • #5 08 Maj 2010 12:41
    marek003
    Poziom 40  

    A czy istnieje coś takiego w open office jak nagrywanie makra?

    Jeżeli jest, to włącz nagrywanie, zaznacz cały arkusz naciśnij del i wyłącz nagrywanie a później spójrz na zapisany kod. Czy nie jest podobny do tego:

    Code:
    Cells.Select
    
    Selection.ClearContents

    Skoryguj różnice.
    Na marginesie ten kawałek kodu ma za zadanie wyczyścić wcześniejszą zawartość arkusza.


    A może wystarczy dodać deklarację użytych przeze mnie zmiennych i troszeczkę poprawić funkcję zaznaczenia.

    Zmień początek procedury
    Code:
    Sub wynik()
    

    Dim a, x, y As Integer

    a = Val(InputBox("Podaj zamówienie"))
    Worksheets("Wynik2").Cells.Select
    Selection.ClearContents

    Resztę zaczynającą się od y=2 pozostaw bez zmian.

    0