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 - problem z przenoszeniem danych między arkuszami

Wieslaw3 19 Gru 2010 21:33 19000 52
  • #31
    adamas_nt
    Moderator Programowanie
    :arrow: marek003
    Nie sugeruj się makrem autora, bo z założenia "obrabia" tylko jeden wiersz (drugi). Trzeba to przerobić tak, czy inaczej...

    :arrow: Wieslaw3
    Uprę się nad zatrzymaniem makra przed wydrukiem. Musisz uprzeć się bardziej ode mnie, żeby mnie przekonać. W swojej procedurze i tak zatrzymywał Cię komunikat (MsgBox "nie widnieje w ewidencji") dla każdego, który "Nie figuruje w ewidencji"...
  • #32
    Wieslaw3
    Poziom 18  
    MsgBox był wstawiony tylko roboczo. Ale OK niech na razie zostanie po Twojemu :) będzie wszystko dobrze to się wrzuci wydruk automatyczny.
  • #33
    adamas_nt
    Moderator Programowanie
    Hmm, coś słabo przekonujesz :)
    Można dodać pole wyboru "drukuj automatycznie" i zaznaczyć (ryzykując), albo nie... :)
  • #34
    Wieslaw3
    Poziom 18  
    Nie przekonuję, bo wydruk jest już "małym piwem". Zastanawiam się nad tym co napisałeś, że moja instrukcja obrabia tylko2 wiersz.
    Obrabia faktycznie 2 wiersz, ale jeśli osoba występowała np 3 razy, wypełnił w arkuszu 3 wiersze - prawidłowo.
  • #35
    adamas_nt
    Moderator Programowanie
    Z Twojej procedury
    Code:
    Sub Petla()
    
     If Range("Z2").Value <> "." Then
    oraz
    Code:
    Arkusz1.Rows("2:2").Delete Shift:=xlUp
    Ale to już nie ma znaczenia...

    A co koledzy na to
    Code:
    Sub Petla()
    
    a = 1
    b = 1
    With Sheets("Arkusz1")
      For i = 2 To Range("B65536").End(xlUp).Row
        liczba = Cells(i, 2)
        If liczba <> Cells(i + 1, 2) Then
          'kopiujemy
          a = i
        Else
          Rows(b + 1 & ":" & i + 1).Select
          MsgBox "jedziemy dalej " & a + 1 & " do " & i + 1
         
          'kopiujemy
          b = a
        End If
        If a = i Then
          Rows(b + 1 & ":" & i).Select
          MsgBox "drukujemy " & b + 1 & " do " & i
          b = i
        End If
      Next
    End With
    End Sub
  • #36
    Wieslaw3
    Poziom 18  
    5 - 6
    5 - 7
    5 - 8...
    tak miało być ?

    Dodano po 6 [minuty]:

    Niestety muszę już opuścić forum. Bardzo dziękuję za wszelką pomoc i liczę na dalszą. Jutro będę zaglądał. Pozdr.
  • #37
    adamas_nt
    Moderator Programowanie
    To tylko schemat działania. W tej formie będzie chyba bardziej oczywisty
    Code:
    Sub Petla()
    
    a = 1
    b = 1
    ark = "Arkusz3 "
    With Sheets("Arkusz1")
      For i = 2 To Range("B65536").End(xlUp).Row
        liczba = Cells(i, 2)
        If liczba <> Cells(i + 1, 2) Then
          wywolanie = druk(ark, b, i)
          a = i
          ark = "Arkusz3 "
          'kopiujemy
        Else
          b = a
          ark = "Arkusz2 "
          'kopiujemy
        End If
        If a = i Then
          Rows(b + 1 & ":" & i).Select
          b = i
        End If
      Next
    End With
    End Sub

    Private Function druk(ark, b, i)
          Rows(b + 1 & ":" & i).Select
          If ark = "Arkusz2 " Then
            MsgBox "drukujemy " & ark & "wiersze: " & b + 1 & " do " & i
          Else
            MsgBox "drukujemy " & ark & "wiersz: " & i
          End If
          druk = Empty
    End Function
  • #38
    marek003
    Poziom 40  
    Nie do końca rozumiem ograniczenia do 1000 w makrze autora. Niby logiczne że po co aż tyle, ale jeżeli rzeczywiście byłoby tyle danych to czego tego nie drukować.

    Nie zmieniałem idei autora ale pozwoliłem sobie trochę ją uporządkować (przy czym wyrzuciłem ten 1000 ale jak trzeba to ...)
    Zamknąłem wszystko w pętli Do While .. Loop by robiło się do końca danych z Arkusz1 i na razie "wyłączyłem" wydruki (apostrof przed linią kodu) by nie marnować kartek.
    Dodałem ramki, wielkość czcionki i czyszczenie danych po wydruku.

    Code:
    Sub Petla()
    
    Dim NumerWiersza As Integer
    Dim NumerKolumny As Integer
     
    Do While Arkusz1.Range("A2") <> ""

     If Arkusz1.Range("Z2").Value <> "." Then
       
       Arkusz3.Range("D10").Value = Arkusz1.Range("P2").Value
       Arkusz3.Range("D11").Value = Arkusz1.Range("R2").Value
       
       key = MsgBox("Nie widnieje w ewidencji." & Chr(10) & Chr(10) & "Czy drukować Arkusz3", vbYesNo)
      ' If key = 6 Then Arkusz3.PrintOut Copies:=1
       
    'czyszczenie danych
       Arkusz1.Rows("2:2").Delete Shift:=xlUp
       Arkusz3.Range("D10").Value = ""
       Arkusz3.Range("D11").Value = ""
     
     Else
       
        PESEL = WorksheetFunction.CountIf(Arkusz1.Range("B1:B100"), Arkusz1.Range("B2").Value)
     
        NumerWiersza = 13
        NumerKolumny = 1

        For kolumna = 1 To PESEL
           
            Arkusz2.Range("E10").Value = Arkusz1.Range("P2").Value
            Arkusz2.Range("G10").Value = Arkusz1.Range("R2").Value
            Arkusz2.Range("E11").Value = Arkusz1.Range("U2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny).Value = Arkusz1.Range("AF2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 1).Value = Arkusz1.Range("AB2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 2).Value = Arkusz1.Range("AD2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 3).Value = Arkusz1.Range("AE2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 4).Value = Arkusz1.Range("AI2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 5).Value = Arkusz1.Range("AG2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 6).Value = Arkusz1.Range("AA2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 7).Value = Arkusz1.Range("AJ2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 8).Value = Arkusz1.Range("AN2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 9).Value = Arkusz1.Range("AO2").Value

            Arkusz1.Rows("2:2").Delete Shift:=xlUp
                   
            NumerWiersza = NumerWiersza + 1
           
       Next kolumna
    'Ramki
        Arkusz2.Range(Cells(13, NumerKolumny), Cells(NumerWiersza - 1, NumerKolumny + 9)).Select
        Selection.Font.Size = 8
        Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
        Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
        Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
        Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
        Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
        If NumerWiersza > 14 Then Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
           
       key = MsgBox("Czy drukować Arkusz2", vbYesNo)
       'If key = 6 Then Arkusz2.PrintOut Copies:=1
       
    'Czyszczenie danych
        Arkusz2.Range("E10").Value = ""
        Arkusz2.Range("G10").Value = ""
        Arkusz2.Range("E11").Value = ""
        Arkusz2.Range(Cells(13, NumerKolumny), Cells(NumerWiersza - 1, NumerKolumny + 9)).Delete Shift:=xlUp
     
     
     End If

    Loop

    End Sub


    Poniżej przykład


    dodane po chwili
    -----------------------------------

    Coś mam kłopoty z odświeżaniem forum. Po umieszczeniu mojego tekstu dopiero widzę wasze wpisy - nie wiem co jest.

    W takim wypadku jestem nie na czasie, więc sorki.

    dodane po kolejnej chwili
    ---------------------------
    Już wiem co było nie tak. Aż wstyd się przyznać. Odświeżałem pierwszą stronę dyskusji. Chyba jestem już śpiący.
  • #39
    Wieslaw3
    Poziom 18  
    Nie wytrzymałem i zajrzałem jeszcze na forum :)
    Wielkie dzięki działa super!!!
    W prowadziłem maleńką kosmetykę:

    Code:
    Sub FORUM2()
    
    Sheets("Arkusz2").Select
    Dim NumerWiersza As Integer
    Dim NumerKolumny As Integer
     
    Do While Arkusz1.Range("A2") <> ""

     If Arkusz1.Range("Z2").Value <> "." Then

       Arkusz3.Range("C11").Value = Arkusz1.Range("P2").Value
       Arkusz3.Range("D11").Value = Arkusz1.Range("R2").Value
    Sheets("Arkusz3").Select
       key = MsgBox("Nie widnieje w ewidencji." & Chr(10) & Chr(10) & "Czy drukować Arkusz3", vbYesNo)
      ' If key = 6 Then Arkusz3.PrintOut Copies:=1
       
       Sheets("Arkusz2").Select
    'czyszczenie danych
       Arkusz1.Rows("2:2").Delete Shift:=xlUp
       Arkusz3.Range("C11").Value = ""
       Arkusz3.Range("D11").Value = ""
     
     Else
       
        PESEL = WorksheetFunction.CountIf(Arkusz1.Range("B1:B100"), Arkusz1.Range("B2").Value)
     
        NumerWiersza = 13
        NumerKolumny = 1

        For kolumna = 1 To PESEL
           
            Arkusz2.Range("E10").Value = Arkusz1.Range("P2").Value
            Arkusz2.Range("G10").Value = Arkusz1.Range("R2").Value
            Arkusz2.Range("E11").Value = Arkusz1.Range("U2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny).Value = Arkusz1.Range("AF2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 1).Value = Arkusz1.Range("AB2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 2).Value = Arkusz1.Range("AD2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 3).Value = Arkusz1.Range("AE2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 4).Value = Arkusz1.Range("AI2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 5).Value = Arkusz1.Range("AG2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 6).Value = Arkusz1.Range("AA2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 7).Value = Arkusz1.Range("AJ2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 8).Value = Arkusz1.Range("AN2").Value
            Arkusz2.Cells(NumerWiersza, NumerKolumny + 9).Value = Arkusz1.Range("AO2").Value

            Arkusz1.Rows("2:2").Delete Shift:=xlUp
                   
            NumerWiersza = NumerWiersza + 1
           
       Next kolumna
    'Ramki
        Arkusz2.Range(Cells(13, NumerKolumny), Cells(NumerWiersza - 1, NumerKolumny + 9)).Select
        Selection.Font.Size = 8
        Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
        Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
        Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
        Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
        Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
        If NumerWiersza > 14 Then Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
           
       key = MsgBox("Czy drukować Arkusz2", vbYesNo)
       'If key = 6 Then Arkusz2.PrintOut Copies:=1
       
    'Czyszczenie danych
        Arkusz2.Range("E10").Value = ""
        Arkusz2.Range("G10").Value = ""
        Arkusz2.Range("E11").Value = ""
        Arkusz2.Range(Cells(13, NumerKolumny), Cells(NumerWiersza - 1, NumerKolumny + 9)).Delete Shift:=xlUp
     
     
     End If

    Loop

    End Sub

    Tylko nie mogę się doszukać jednego. Makro chyba gdzieś czyści formaty komórek gdyż Arkusz2 miał ustawione w komórkach tabelki zawijanie tekstu. Niestety po wykonaniu makra już nie zawija.
  • #40
    marek003
    Poziom 40  
    By zawijało trzeba dodać jeszcze "przed ramkami" wiersz
    Code:
    Selection.WrapText = True


    Zaktualizowałem poprzedni załącznik o ten wiersz i twoje poprawki z "przerzutem" arkuszy
  • #41
    Wieslaw3
    Poziom 18  
    Teraz OK.
    A jak zmodyfikować linijkę
    Code:
    If key = 6 Then Arkusz3.PrintOut Copies:=1

    żeby poszło na drukarkę inną niż domyślna
    Nazwa drukarki do XEROA5

    PS. Modyfikacja załącznika nie potrzebna. Ja i tak kopiuję kod VBA i wklejam do swojego makra.
  • Pomocny post
    #42
    marek003
    Poziom 40  
    Tu jest przykład jak bym chciał to wydrukować na drukarce mojej koleżanki z pracy:

    Code:
    If key = 6 Then Arkusz3.PrintOut Copies:=1, ActivePrinter:="\\MAŁGOSIA\HP LaserJet 3200 Series PCL 6 na Ne06:", Collate:=True


    Jeżeli znasz adres XEROA5 to wpisz jak nie to wykorzystaj nagrywanie makra.

    Włącz "zarejestruj makro".
    Wybierz menu plik, drukuj... , zmień drukarkę i wciśnij drukuj.
    Zatrzymaj rejestrowanie makr.

    Wejdź w edytor VBA powstanie nowy moduł/procedura macro1().
    Zobacz co się wpisało i skopiuj po Copies:=1 "końcówkę" kodu i wklej do twojego kodu (pamiętaj o przecinku).
  • #43
    Wieslaw3
    Poziom 18  
    Dziękuję bardzo za pomoc - większość gotowa.
    Teraz na podstawie tego co mam muszę dorobić dalszą część marka importujące kolejny pik - jego zawartość i struktura jest już mniej skomplikowana, zawiera mniej informacji. problemem dla mnie może być tylko połączenie nowych procedur z istniejącymi tak, żeby wszystko odpalało się tak jak dotychczas 2 przyciskami: "IMPORTUJ" i "WYDRUK"
  • #44
    marek003
    Poziom 40  
    Za mało danych aby ci podpowiedzieć konkretnie. [jaki plik, jak się nazywa(czy zawsze tak samo), jak struktura itd.] A może wystarczy tylko "odśwież dane".

    Na pewno import zrób w innej procedurze (ja bym tak zrobił) i podepnij pod inny przycisk.

    Możesz nagrać makro (gdy importujesz plik)
    Następnie zobacz co można w takiej procedurze uprościć i dokładniej wskazać zakresy. Podepnij pod przycisk i już.

    Jeżeli podmienisz/zaktualizujesz plik pojazd.csv może wystarczy procedura odświeżenia danych:

    Code:
    Sub import()
    
    Arkusz1.Range("A1").QueryTable.Refresh BackgroundQuery:=False
    End Sub
  • #45
    Wieslaw3
    Poziom 18  
    Do importu danych które do tej pory obrabialiśmy już dużo wcześniej nagrałem makro i wszystko działa. Dorobiłem do tego przycisk i jest OK.
    Teraz muszę nagrać kolejne makro, które zaimportuje plik wlasciciel.csv (plik zawsze będzie miał tą sama nazwę). Potem trzeba będzie do tego mara dopisać warunek żeby wykonało się pod warunkiem, że plik istnieje (bo nie zawsze plik ten występuje).
    Makro będzie importować plik do arkusza4 potem (podobnie jak poprzednio) kopiować wybrane dane do odpowiednich komórek arkusza5. Zasada ta sama co poprzednio tylko że już nie będzie podziału na 2 arkusze - trochę prościej. Zrobię jakiś zarys i jak utknę w którymś punkcie, poproszę o pomoc.

    Na początek prosił bym o warunek sprawdzający, czy plik istnieje. Lokalizacja to: C:\Import\wlasciciel.csv
  • #46
    adamas_nt
    Moderator Programowanie
    Może zwykłym Dir. Np
    Code:
    Dim pthName As String
    
    pthName = "C:\Import\wlasciciel.csv"

    If Dir(pthName) = "" Then
      MsgBox "brak pliku " & pthName
    Else
      MsgBox "jest " & pthName
      'tu kod
    End If
  • #47
    Wieslaw3
    Poziom 18  
    adamas_nt napisał:
    Może zwykłym Dir. Np
    Code:
    Dim pthName As String
    
    pthName = "C:\Import\wlasciciel.csv"

    If Dir(pthName) = "" Then
      MsgBox "brak pliku " & pthName
    Else
      MsgBox "jest " & pthName
      'tu kod
    End If


    Próbowałem powyższego użyć 2 krotnie w jednym makrze dla pliku pojazd.csv i dla pojazdy.csv ale niestety mam komunikat że:
    Compile error:
    Duplicate declaration in curren scope

    Jak to obejść?
  • #48
    walek33
    Poziom 28  
    Tylko raz zadeklarować pthName.
  • #49
    Wieslaw3
    Poziom 18  
    Czyli przy 2 razie opuścić 2 pierwsze linijki?
  • #50
    walek33
    Poziom 28  
    Tylko pierwszą. W drugiej wpisujesz wartość zmiennej.
  • #51
    Wieslaw3
    Poziom 18  
    Tak, doszedłem do tego. Teraz działa OK :)
  • #52
    fiuku1
    Poziom 12  
    A ja tak czytam i bardzo mnie zainteresowało to co robicie :)
    Wiesław3 możesz wstawić plik/pliki (spakowane RARem najlepiej), które stworzyłeś?
    Byłyby mi bardzo pomocne przy tworzeniu moich raportów.
    Z góry dziękuję, gdyż mam nikłe pojęcia o VBA i uczę się Excela dopiero :)

    Pozdrawiam!
  • #53
    Wieslaw3
    Poziom 18  
    Chętnie ale są tam dane osobowe których nie wolno mi ujawniać :(