Please add exception to AdBlock for elektroda.pl.
If you watch the ads, you support portal and users.

EXCEL - problem z przenoszeniem danych między arkuszami

Wieslaw3 19 Dec 2010 21:33 19933 52

Reply | New topic

#31 19 Dec 2010 21:33

adamas_nt adamas_nt

Moderator of Programming

Helpful post? (0)

#31 19 Dec 2010 21:33

marek003
Nie sugeruj się makrem autora, bo z założenia "obrabia" tylko jeden wiersz (drugi). Trzeba to przerobić tak, czy inaczej...

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 19 Dec 2010 21:37

Wieslaw3 Wieslaw3

Level 18

Topic author Helpful post? (0)

#32 19 Dec 2010 21:37

MsgBox był wstawiony tylko roboczo. Ale OK niech na razie zostanie po Twojemu będzie wszystko dobrze to się wrzuci wydruk automatyczny.
#33 19 Dec 2010 21:40

adamas_nt adamas_nt

Moderator of Programming

Helpful post? (0)

#33 19 Dec 2010 21:40

Hmm, coś słabo przekonujesz
Można dodać pole wyboru "drukuj automatycznie" i zaznaczyć (ryzykując), albo nie...
#34 19 Dec 2010 21:49

Wieslaw3 Wieslaw3

Level 18

Topic author Helpful post? (0)

#34 19 Dec 2010 21:49

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 19 Dec 2010 22:16

adamas_nt adamas_nt

Moderator of Programming

#35 19 Dec 2010 22:16

Z Twojej procedury

Sub Petla()
 If Range("Z2").Value <> "." Then

oraz

Arkusz1.Rows("2:2").Delete Shift:=xlUp

Ale to już nie ma znaczenia...

A co koledzy na to

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 19 Dec 2010 22:37

Wieslaw3 Wieslaw3

Level 18

Topic author Helpful post? (0)

#36 19 Dec 2010 22:37

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 19 Dec 2010 22:48

adamas_nt adamas_nt

Moderator of Programming

#37 19 Dec 2010 22:48

To tylko schemat działania. W tej formie będzie chyba bardziej oczywisty

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 19 Dec 2010 23:12

marek003 marek003

Level 40

#38 19 Dec 2010 23:12

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.

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.

Attachments:

aaa.xls Download (147.5 KB)

#39 19 Dec 2010 23:55

Wieslaw3 Wieslaw3

Level 18

#39 19 Dec 2010 23:55

Nie wytrzymałem i zajrzałem jeszcze na forum

Wielkie dzięki działa super!!!
W prowadziłem maleńką kosmetykę:

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 20 Dec 2010 07:31

marek003 marek003

Level 40
Helpful post? (0)

#40 20 Dec 2010 07:31

By zawijało trzeba dodać jeszcze "przed ramkami" wiersz
Code: text Expand Select all Copy to clipboard
Selection.WrapText = True

Zaktualizowałem poprzedni załącznik o ten wiersz i twoje poprawki z "przerzutem" arkuszy
#41 20 Dec 2010 08:54

Wieslaw3 Wieslaw3

Level 18
Topic author Helpful post? (0)

#41 20 Dec 2010 08:54

Teraz OK.
A jak zmodyfikować linijkę
Code: text Expand Select all Copy to clipboard
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.
Helpful post

#42 20 Dec 2010 11:37

marek003 marek003

Level 40
Helpful post? (+1)

Helpful post #42 20 Dec 2010 11:37

Tu jest przykład jak bym chciał to wydrukować na drukarce mojej koleżanki z pracy:

Code: text Expand Select all Copy to clipboard
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 20 Dec 2010 12:37

Wieslaw3 Wieslaw3

Level 18

Topic author Helpful post? (0)

#43 20 Dec 2010 12:37

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 20 Dec 2010 16:48

marek003 marek003

Level 40
Helpful post? (0)

#44 20 Dec 2010 16:48

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: text Expand Select all Copy to clipboard
Sub import() Arkusz1.Range("A1").QueryTable.Refresh BackgroundQuery:=False End Sub
#45 20 Dec 2010 19:22

Wieslaw3 Wieslaw3

Level 18

Topic author Helpful post? (0)

#45 20 Dec 2010 19:22

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 20 Dec 2010 20:03

adamas_nt adamas_nt

Moderator of Programming

#46 20 Dec 2010 20:03

Może zwykłym Dir. Np

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 21 Dec 2010 09:26

Wieslaw3 Wieslaw3

Level 18
Topic author Helpful post? (0)

#47 21 Dec 2010 09:26

adamas_nt wrote:
Może zwykłym Dir. Np
Code: text Expand Select all Copy to clipboard
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 21 Dec 2010 13:52

walek33 walek33

Level 29

Helpful post? (0)

#48 21 Dec 2010 13:52

Tylko raz zadeklarować pthName.
#49 21 Dec 2010 14:27

Wieslaw3 Wieslaw3

Level 18

Topic author Helpful post? (0)

#49 21 Dec 2010 14:27

Czyli przy 2 razie opuścić 2 pierwsze linijki?
#50 21 Dec 2010 14:49

walek33 walek33

Level 29

Helpful post? (0)

#50 21 Dec 2010 14:49

Tylko pierwszą. W drugiej wpisujesz wartość zmiennej.
#51 21 Dec 2010 15:12

Wieslaw3 Wieslaw3

Level 18

Topic author Helpful post? (0)

#51 21 Dec 2010 15:12

Tak, doszedłem do tego. Teraz działa OK
#52 23 Dec 2010 13:37

fiuku1 fiuku1

Level 13

Helpful post? (0)

#52 23 Dec 2010 13:37

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 23 Dec 2010 20:37

Wieslaw3 Wieslaw3

Level 18

Topic author Helpful post? (0)

#53 23 Dec 2010 20:37

Chętnie ale są tam dane osobowe których nie wolno mi ujawniać
Create an account, log in and become active in a forum and ads will not appear. You will receive points by participating in discussions.
Join this discussion.

Log in with Google

Reply | New topic

Home page
/
Forum
/
Computer Service
/
Computer Software
/
EXCEL - problem z przenoszeniem danych między arkuszami