Προς το περιεχόμενο

Μεταφορά δεδομένων ενός φύλλου εργασίας σε ένα άλλο στο Excel με Visual Basic

bilakos26

Από τον bilakos26
στο Προγραμματισμός

 Share

Προτεινόμενες αναρτήσεις

bilakos26 Contributor

bilakos26

Δημοσ.
Δημοσ.

Θα ήθελα εάν γνωρίζει κάποιος να μου πει πως μπορώ να μεταφέρω κάποια δεδομένα από ένα φύλλο εργασίας (π.χ Φύλλο1) σε ένα άλλο (π.χ Φύλλο2) χρησιμοποιώντας μακροεντολές με την Visual Basic.

 

Έχω για παράδειγμα στην στήλη Α1, Α2 , Α3, Α4 , Α5 κάποια ονόματα, στην σειρά Β1, Β2, Β3, Β4 , Β5 καποια τηλεφωνα και στην σειρα Γ1, Γ2, Γ3, Γ4, Γ5 καποιες διευθυνσεις.
Όλα αυτά θέλω με το πάτημα ενός κουμπιού(όχι από το πληκτρολόγιο αλλά με την δημιουργία ενός στο Excel) να μου τα μεταφέρει αυτόματα στο Φύλλο2 και στις ανάλογες στήλες.

 

Γνωρίζετε πως μπορεί να υλοποιηθεί αυτό;

Mpiftekis Mentor

Mpiftekis

Δημοσ.
Δημοσ. 
SUB ANTIGRAFI()
For i=1 to 3
 for j=1 to 1500 'εδώ βάζεις τον αριθμό της πρώτης και τελευταίας γραμμής προς αντιγραφή'
   worksheets(2).cells(i,j)=worksheets(1).cells(i,j)
  next j
next i

END SUB

Δε θυμάμαι πώς μπαίνουν τα (i,j). Μπορεί να είναι και (j,i). Δοκίμασε και βλέπεις.

 

Αν δεν ξέρεις πόσες θα είναι οι γραμμές τότε πρέπει να βάλεις έναν counter να σου μετρήσει τα μη κενά κελιά στην πρώτη στήλη.

Mpiftekis Mentor

Mpiftekis

Δημοσ.
Δημοσ.

Mpiftekis μπορείς να μου εξηγήσεις πως βάζω αυτόν τον counter;

SUB ANTIGRAFI()


k=1 'k είναι ο counter'
do while worksheets(1).cells(k,1)<>"" 'εδώ αρχίζει και μετράει τα μη κενά κελιά'
  k=k+1
loop

For i=1 to 3
 for j=1 to k 'εδώ βάζεις τον αριθμό της πρώτης και τελευταίας γραμμής προς αντιγραφή'
   worksheets(2).cells(i,j)=worksheets(1).cells(i,j)
  next j
next i

END SUB

Θα σου πρότεινα να ονομάσεις τα φύλλα με αγγλικούς χαρακτήρες ώστε να μη δημιοθργηθεί πρόβλημα με την πρόσθεση ή αφαίρεση κανούριων φύλλων στο excel workbook. Αν τους δώσεις όνομα πχ "original" & "antigrafo", τότε αντί για worksheets(1) θα βάλεις  worksheets("original").

 

Επίσης, αν για κάποιο λόγο υπάρχει κενό στις καταχωρήσεις στις γραμμές, τότε ο counter θα μετρήσει μέχρι το κενό και όχι παρακάτω.

bilakos26 Contributor

bilakos26

Δημοσ.
  • Μέλος
Δημοσ. 
SUB ANTIGRAFI()


k=1 'k είναι ο counter'
do while worksheets(1).cells(k,1)<>"" 'εδώ αρχίζει και μετράει τα μη κενά κελιά'
  k=k+1
loop

For i=1 to 3
 for j=1 to k 'εδώ βάζεις τον αριθμό της πρώτης και τελευταίας γραμμής προς αντιγραφή'
   worksheets(2).cells(i,j)=worksheets(1).cells(i,j)
  next j
next i

END SUB

Θα σου πρότεινα να ονομάσεις τα φύλλα με αγγλικούς χαρακτήρες ώστε να μη δημιοθργηθεί πρόβλημα με την πρόσθεση ή αφαίρεση κανούριων φύλλων στο excel workbook. Αν τους δώσεις όνομα πχ "original" & "antigrafo", τότε αντί για worksheets(1) θα βάλεις  worksheets("original").

 

Επίσης, αν για κάποιο λόγο υπάρχει κενό στις καταχωρήσεις στις γραμμές, τότε ο counter θα μετρήσει μέχρι το κενό και όχι παρακάτω.

 

 

Δεν λειτουργει δυστυχως.

Θα ανεβασω μερικες φωτογραφιες γιατι προσθεσα και μερικες ακομη στειλες αλλα και για να το κανω καπως ποιο ευκολο στην κατανοηση.

 

Στην εικονα1 θελω οτι εχω κυκλωμενο να πηγαινει στα αντιστοιχα σημεια της εικονας.

 

Αν το καταφερεις αυτο ή οποιοσδηποτε αλλος θα του ημουν ευγνωμον .

 

post-409028-0-82776200-1501757941_thumb.png

post-409028-0-40313800-1501757956_thumb.png

Mpiftekis Mentor

Mpiftekis

Δημοσ.
Δημοσ.

Δεν λειτουργει δυστυχως.

Θα ανεβασω μερικες φωτογραφιες γιατι προσθεσα και μερικες ακομη στειλες αλλα και για να το κανω καπως ποιο ευκολο στην κατανοηση.

 

Στην εικονα1 θελω οτι εχω κυκλωμενο να πηγαινει στα αντιστοιχα σημεια της εικονας.

 

Αν το καταφερεις αυτο ή οποιοσδηποτε αλλος θα του ημουν ευγνωμον .

 

Το φορμάτ του φύλλου αυτού είναι φιξ; Δηλαδή στη γραμμή 41 θα είναι πάντα η καθαρή αξία;

Mpiftekis Mentor

Mpiftekis

Δημοσ.
Δημοσ.

Ναι φίλος

SUB ANTIGRAFI()


k=7 'k είναι ο counter original'
do while worksheets("original").cells(k,1)<>"" 'εδώ αρχίζει και μετράει τα μη κενά κελιά'
  k=k+1
loop
k=k-1

l=2 'l είναι ο counter eponymia antigrafo'
do while worksheets("antigrafo").cells(l,1)<>"" 'εδώ αρχίζει και μετράει τα μη κενά κελιά'
  l=l+1
loop


for j=7 to k 'εδώ βάζεις τον αριθμό της πρώτης και τελευταίας γραμμής προς αντιγραφή'
   worksheets("antigrafo").cells(l+j-7,1)=worksheets("original").cells(4,3) 'eponymia
   worksheets("antigrafo").cells(l+j-7,2)=worksheets("original").cells(j,3) 'eidos
   worksheets("antigrafo").cells(l+j-7,3)=worksheets("original").cells(j,1) 'posotita
   worksheets("antigrafo").cells(l+j-7,4)=worksheets("original").cells(41,6) 'a3ia
   worksheets("antigrafo").cells(l+j-7,5)=worksheets("original").cells(43,6) 'pliroteo

next j


END SUB

Μετονόμασε τα φύλλα σε "original" & "antigrafo" και δες αν δουεύει αυτό.

bilakos26 Contributor

bilakos26

Δημοσ.
  • Μέλος
Δημοσ. 
SUB ANTIGRAFI()


k=7 'k είναι ο counter original'
do while worksheets("original").cells(k,1)<>"" 'εδώ αρχίζει και μετράει τα μη κενά κελιά'
  k=k+1
loop
k=k-1

l=2 'l είναι ο counter eponymia antigrafo'
do while worksheets("antigrafo").cells(l,1)<>"" 'εδώ αρχίζει και μετράει τα μη κενά κελιά'
  l=l+1
loop


for j=7 to k 'εδώ βάζεις τον αριθμό της πρώτης και τελευταίας γραμμής προς αντιγραφή'
   worksheets("antigrafo").cells(l+j-7,1)=worksheets("original").cells(4,3) 'eponymia
   worksheets("antigrafo").cells(l+j-7,2)=worksheets("original").cells(j,3) 'eidos
   worksheets("antigrafo").cells(l+j-7,3)=worksheets("original").cells(j,1) 'posotita
   worksheets("antigrafo").cells(l+j-7,4)=worksheets("original").cells(41,6) 'a3ia
   worksheets("antigrafo").cells(l+j-7,5)=worksheets("original").cells(43,6) 'pliroteo

next j


END SUB

Μετονόμασε τα φύλλα σε "original" & "antigrafo" και δες αν δουεύει αυτό.

 

do while worksheets("original").cells(k,1)<>"" 'εδώ αρχίζει και μετράει τα μη κενά κελιά' 

Σε αυτο μου βγαζει error 

 

εκει που λες οτι βαζω τον αριθμο της πρωτης και τελευταιας γραμμης προς αντιγραφη πρεπει να βαλω στο k, π.χ το k = 40 ;

Βασικα τωρα παρατηρησα οτι δεν εχεις συμπεριλαβει την ΠΕΡΙΓΡΑΦΗ ΕΙΔΟΥΣ και την ΚΑΘΑΡΗ ΑΞΙΑ. 

Αν βρεις το προβλημα που εμφανιζεται συμπεριελαβε και αυτα αν γινεται.

 

 

Mpiftekis Mentor

Mpiftekis

Δημοσ.
Δημοσ.

do while worksheets("original").cells(k,1)<>"" 'εδώ αρχίζει και μετράει τα μη κενά κελιά' 

Σε αυτο μου βγαζει error 

 

εκει που λες οτι βαζω τον αριθμο της πρωτης και τελευταιας γραμμης προς αντιγραφη πρεπει να βαλω στο k, π.χ το k = 40 ;

Βασικα τωρα παρατηρησα οτι δεν εχεις συμπεριλαβει την ΠΕΡΙΓΡΑΦΗ ΕΙΔΟΥΣ και την ΚΑΘΑΡΗ ΑΞΙΑ. 

Αν βρεις το προβλημα που εμφανιζεται συμπεριελαβε και αυτα αν γινεται.

 

Αυτό το έκανες;; "Μετονόμασε το φύλλο 1 σε "original" & φύλλο 2 σε"antigrafo".

 

Θες να αντιγράψεις τη συνολική καθαρή αξία ή την αξία για κάθε είδος;

 

Υ.Γ.: έχω βάλει να αντιγράφει την τελική καθαρή αξία και το είδος. Μην πειράξεις τίποτα άλλο. Άσε το k όπως είναι.

bilakos26 Contributor

bilakos26

Δημοσ.
  • Μέλος
Δημοσ. (επεξεργασμένο)

Αυτό το έκανες;; "Μετονόμασε το φύλλο 1 σε "original" & φύλλο 2 σε"antigrafo".

 

Θες να αντιγράψεις τη συνολική καθαρή αξία ή την αξία για κάθε είδος;

 

Υ.Γ.: έχω βάλει να αντιγράφει την τελική καθαρή αξία και το είδος. Μην πειράξεις τίποτα άλλο. Άσε το k όπως είναι.

Ναι το εκανα αυτο που μου ειπες.

Θελω να αντιγραψω την καθαρη αξια που μου βρισκει απο τα προηγουμενα κελια αλλα θελω το κελι F41 για την καθαρη αξια.

Ακομη και να αφησω το k οπως ειναι παλι μου βγαζει το error και πιο συγκεκριμενα λεει ( Run-time error '9': Subscript out of range).

Βρηκα τι εκανα εγω λαθος. Ειχα αλλαξει την ονομασια απο τις ιδιοτητες των μακροεντολων και οχι κατω στα φυλλα εργασιας.

Το προβλημα πλεον ομως ειναι οτι η συναρτηση που εχω βαλη στην ΤΕΛΙΚΗ ΑΞΙΑ οταν το στελνω στο ΠΛΗΡΩΤΕΟ μου εμφανιζει ημερομηνια και ωρα εντελως ασχετες με την τωρινη ημερομηνια και ωρα.

 

Ακομη οταν στελνω τα αρχεια στο antigrafo (π.χ πιο πριν ειχα βαλει αλλα στοιχεια στην ΕΠΩΝΥΜΙΑ και σε ολα τα υπολοιπα), οταν μου τα περασει στο antigrafo και παω να κανω το επομενο antigrafo, τα στοιχεια που ειχανε περαστει πριν δεν θελω να διαγραφουνε αλλα να παραμεινουνε και τα τωρινα στοιχεια να περαστουν ακριβως απο κατω, κατι το οποιο ομως με τον συγκεκριμενο προγραμματισμο που μου εστειλες δεν γινεται.

 

Επισης δεν μου περναει και την ΕΠΩΝΥΜΙΑ του πελατη.

Στις εικόνες παρεχω ολοκληρο τον κωδικα που εχω οταν παταω ενα συγκεκριμενο κουμπι στο excel αλλα θα αναλυσω και τι κανω με το συγκεκριμενο αρχειο.

 

Λοιπον το ολο σχεδιο με το συγκεκριμενο excel αρχειο ειναι οταν παταω στην επωνυμια, δηλαδη στα ονοματα των πελατων μου μου βγαζει μια λιστα drop down η οποια εχει ολα τα ονοματα των πελατων μου απο το φυλλο εργασια ΠΕΛΑΤΕΣ.

Στο επομενο βημα με διαφορες συναρτησεις περνω απο την ΠΟΣΟΤΗΑ και την ΤΙΜΗ (τιμη μοναδας δηλαδη)   και βγαζω την ΚΑΘΑΡΗ ΑΞΙΑ, η οποια αργοτερα με την προσθηκη του ΦΠΑ μου βγαζει με μια αλλη συναρτηση την ΤΕΛΙΚΗ ΑΞΙΑ.

Επισης εχω βαλει ενα ακομη drop down και στην ΠΕΡΙΓΡΑΦΗ ΕΙΔΟΥΣ οπου περνει τις ονομασιες των προϊοντων μου απο το φυλλο εργασια ΠΡΟΪΟΝΤΑ και μου βγαζει μια λιστα με αυτα. 

 

Μεχρι εδω δεν χρησιμοποιω κατι στην Visual Basic.

 

Υστερα τοποθετω ενα κουμπι με το ονομα ΕΚΤΥΠΩΣΗ και βαζω την μακροεντολη που εχω γραψει στις 2 εικονες. Η λειτουργια του ουσιαστικα ειναι να κανει ενα αντιγραφο PDF στον φακελο απο το πρωτο φυλλο εργασιας original, να με ρωτησει αν θελω να το εκτυπωσω και υστερα να αδιασει τις σειρες για το επομενο συναλλαγμα.

Sub ΜΠΑΚΑΛΟΧΑΡΤΟ()

Dim  ΑΡΧΕΙΟ() As Variant
FYLLO = ActiveSheet.Name
Sheets(FYLLO).Select

'ONOMA GIA TO PARASTATIKO
If PARASTATIKO_TIM = "ΜΠΑΚΑΛΟΧΑΡΤΟ" Then
End If

'BRES TO PATH POY EINAI SOSMENO TO EXCEL
Current_Path = Application.ActiveWorkbook.Path
PDF_PARASTATIKO = PARASTATIKO_TIM 'PARASTATIKO GIA TO PDF
PDF_DATE = Format(ActiveSheet.Cells(2, 6).Value, "dd-mm-yyyy hh.mm")  'HMEROMHNIA

k = 7 'k είναι ο counter original'
Do While Worksheets("original").Cells(k, 1) <> "" 'εδώ αρχίζει και μετράει τα μη κενά κελιά'
  k = k + 1
Loop
k = k - 1

l = 2 'l είναι ο counter eponymia antigrafo'
Do While Worksheets("antigrafo").Cells(l, 1) <> "" 'εδω αρχίζει και μετράει τα μη κενά κελιά'
  l = l + 1
Loop


For j = 7 To k 'εδώ βάζεις τον αριθμό της πρώτης και τελευταίας γραμμής προς αντιγραφή'
   Worksheets("antigrafo").Cells(l + j - 7, 1) = Worksheets("original").Cells(4, 3) 'eponymia
   Worksheets("antigrafo").Cells(l + j - 7, 2) = Worksheets("original").Cells(j, 3) 'eidos
   Worksheets("antigrafo").Cells(l + j - 7, 3) = Worksheets("original").Cells(j, 1) 'posotita
   Worksheets("antigrafo").Cells(l + j - 7, 4) = Worksheets("original").Cells(41, 6) 'a3ia
   Worksheets("antigrafo").Cells(l + j - 7, 5) = Worksheets("original").Cells(43, 6) 'pliroteo

Next j

'SOSE ENA PDF STON IDIO FAKELO
Sheets(FYLLO).Select

'PATH KAI ONOMA ARXEIOY
Current_Path = Current_Path & "\" & PDF_PARASTATIKO & "ΜΠΑΚΑΛΟΧΑΡΤΟ_" & PDF_DATE
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Current_Path, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

'EROTHSH EAN THELEI KI EKTYPOSH STO XARTI
PlainPaper = MsgBox("Θέλετε να γίνει εκτύπωση σε χαρτί;", vbQuestion + vbYesNo)
If PlainPaper = vbYes Then
    'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
    Application.Dialogs(xlDialogPrint).Show
End If

'ADEIASE TO SHEET GIA NA EINAI ETOIMO GIA TO EPOMENO
Sheets(FYLLO).Select

For k = 7 To 40
    ActiveSheet.Cells(k, 3) = "" 'ΠΕΡΙΓΡΑΦΗ ΕΙΔΟΥΣ
    ActiveSheet.Cells(k, 2) = "" 'TEMAXIA
    ActiveSheet.Cells(k, 1) = "" 'ΠΟΣΟΤΗΤΑ
    ActiveSheet.Cells(k, 4) = "" 'TIMH MONADOS
Next k


ActiveSheet.Cells(4, 2) = "" 'ΠΕΛΑΤΗΣ
ActiveSheet.Cells(42, 6) = "" 'ΦΠΑ
ActiveSheet.Cells(2, 6) = "=now()" 'HMEROMHNIA
ActiveSheet.Cells(3, 6) = "=now()" 'ORA


End Sub

Εγω θελω να μου μετακινει καθε φορα την ΕΠΩΝΥΜΙΑ, την ΠΕΡΙΓΡΑΦΗ ΕΙΔΟΥΣ, την ΠΟΣΟΤΗΤΑ, την ΚΑΘΑΡΗ ΑΞΙΑ και την ΤΕΛΙΚΗ ΑΞΙΑ στο φυλλο εργασιας antigrafo στις αντιστοιχες ονομασιες και να τα βαζει το ενα κατω απο το αλλο καθε φορα που θα παταω το κουμπι ΕΚΤΥΠΩΣΗ και οχι να μου διαγραφει τα παλια με καινουργια κατι το οποιο κανει τωρα με τον συγκεκριμενο κωδικα.

 

Ελπιζω να μην κουραζω.

 

Ευχαριστω για οποιαδηποτε απαντηση που θα βοηθησει. 

post-409028-0-90858900-1501781621_thumb.png

post-409028-0-81493500-1501782130_thumb.png

post-409028-0-84474700-1501782144_thumb.png

post-409028-0-94168000-1501782170_thumb.png

post-409028-0-03933800-1501782180_thumb.png

post-409028-0-50935300-1501782191_thumb.png

post-409028-0-40660300-1501782201_thumb.png

Επεξ/σία από bilakos26
Mpiftekis Mentor

Mpiftekis

Δημοσ.
Δημοσ.

Λοιπόν, στο πληρωτέο που σου βγάζει ημ/νια άλλαξε το φορματ του κελιού σε αριθμό.

 

Τώρα σε αυτό το τμήμα του κώδικα:

   worksheets("antigrafo").cells(l+j-7,1)=worksheets("original").cells(4,3) 'eponymia
   worksheets("antigrafo").cells(l+j-7,2)=worksheets("original").cells(j,3) 'eidos
   worksheets("antigrafo").cells(l+j-7,3)=worksheets("original").cells(j,1) 'posotita
   worksheets("antigrafo").cells(l+j-7,4)=worksheets("original").cells(41,6) 'a3ia
   worksheets("antigrafo").cells(l+j-7,5)=worksheets("original").cells(43,6) 'pliroteo

μπορείς να αλλάξεις τους αριθμούς στα "cells(x,y)", όπου χ ο αριθμός της γραμμής και y ο αριθμός της στήλης, ώστε να σου αντιγράφει αυτό που θες.

 

Στο λέω αυτό γιατί δεν κατάλαβα αν θες την αξία του κάθε προϊόντος ξεχωριστά ή την τελική. Κι αν θες και τις 2 δε βλέπω που θες να στις αντιγράψει.

 

Εδιτ: Επίσης, με το F8 μπορείς να τρέξεις την μακροεντολή γραμμή-γραμμή ώστε να δεις τι γίνεται λάθος και να το διορθώσεις.

Δημιουργήστε ένα λογαριασμό ή συνδεθείτε για να σχολιάσετε

Πρέπει να είστε μέλος για να αφήσετε σχόλιο

Δημιουργία λογαριασμού

Εγγραφείτε με νέο λογαριασμό στην κοινότητα μας. Είναι πανεύκολο!

Δημιουργία νέου λογαριασμού

Σύνδεση

Έχετε ήδη λογαριασμό; Συνδεθείτε εδώ.

Συνδεθείτε τώρα
 Share
Προς την λίστα θεμάτων
  • Δημιουργία νέου...