Macro Xls (VB)

[nikosjc]

Καλημέρα,

 

προσπαθώ να φτιάξω μια μακροεντολή που να κάνει το εξής. Από το φύλλο 1 ενός εξελ που περιέχει 1 σταθερή στήλη (Α) και από κει και πέρα άγνωστο αριθμό μεταβαλλόμενων στηλών (με διάφορες τιμές κάθε φορά) πχ.

 

...........Α................................Β..............................C

Ανταλλακτικά.................. Έργο 1.................. Έργο 2 .... (άγνωστος αριθμός έργων κάθε φορά)

Ανταλλακτικό 1................ 5.................................7

Ανταλλακτικό 2................ 0.................................3

Ανταλλακτικό 3................ 3.................................9

 

Θέλω η μακροεντολή να φτιάχνει ένα νέο φύλλο για κάθε έργο (1,2,3 και όσα υπάρχουν) που θα περιέχει την πρώτη στήλη (Α) στην αντίστοιχη στήλη Α του νέου φύλλου και την αντίστοιχη στήλη (αναλόγως το έργο Β,C,D,κλπ) στη στήλη Β του νέου φύλλου. Ταυτόχρονα θα ονοματίζει και το φύλλο με το όνομα του έργου.

 

Μέχρι στιγμής έχω καταφέρει κάποια (δημιουργία νέου φύλλου, ονομασία του με το έργο 1, αντιγραφή των στηλών που θέλω στο νέο φύλλο "έργο 1"). Το πρόβλημα μου είναι η επιλογή της επόμενης στήλης για αντιγραφή (έργο 2, μετά έργο 3, κλπ) και ο έλεγχος να σταματάει όταν φτάνει σε κενή στήλη.

 

Όποιος μπορεί να βοηθήσει...

 

Ευχαριστώ!

 

 

 

Στο παράδειγμα η σταθερή στήλη μου είναι η Β και η πρώτη από τις μεταβαλλόμενες είναι η G και τις αντιγράφει πάντα στην C και H κάθε νέου φύλλου. Θέλω μια ρουτίνα που να αλλάζει το G σε H, I, J, κλπ κάνοντας έλεγχο μεχρι το πρώτο κελί κάποιας στήλης να μην έχει τιμή.

 

 

' Εισαγωγή νέου φύλλου

Sheets.Add After:=Sheets(1)

Sheets(1).Select

 

' Νεό φύλλο

' Ονομασία νέου φύλλου από πρώτο επιλεγμένο κελί (πχ έργο 1)

Range("G1").Select

Sheets(2).Name = ActiveCell.Value

 

' Αντιγραφές στηλών

Sheets(1).Select

Range("B2:B500").Select

Selection.Copy

Sheets(2).Select

Range("C1").Select

ActiveSheet.Paste

 

Sheets(1).Select

Range("G2:G500").Select

Selection.Copy

Sheets(2).Select

Range("H1").Select

ActiveSheet.Paste

 

 

Ένα 2ο που θα με ενδιέφερε, είναι όταν παίρνει την στήλη Β και την στηλή (G ή Η ή I, κλπ) να ελέγχει αν η 2η στήλη έχει τιμή 0 και να σβήνει το ανταλλακτικό. (Αυτό δεν πρέπει να είναι δύσκολο, κάποια στιγμή το είχα βρει, αλλά δεν το θυμάμαι).

 

Και πάλι ευχαριστώ!

 

 

[Crizzt]

Για να βρεις το ποσα εργα εχεις, κανεις κατι τετοιο

 

>Dim NoOfErga As Integer
NoOfErga = Range("B2").End(xlToRight).column - 1

 

Και μετα για να εκτελεσεις καποιο κωδικα τοσες φορες βαζεις ενα For Loop πχ

>For columnIndex = 2 To NoOfErga
  blah blah
Next columnIndex

 

Μπορει να περιεχει λαθη το παραπανω

[nikosjc]

Με βοήθησε ένα παλικάρι από άλλο forum, ανεβάζω και εδώ τον κώδικα μήπως ενδιαφέρει κάποιον. Είναι πολύ καλή λύση και ακριβώς αυτό που ήθελα.

 

 

 

 

Sub ColumnsToSheets()

Dim s, ia, ib, j As Integer

Dim temp As Variant

 

' Φύλλο 2, Στήλη G

s = 2

j = 7

 

' Όσο δεν είναι κενό το πρώτο κελί της στήλης j επαναλαμβάνει

While Worksheets(1).Cells(1, j) <> ""

 

' Εισαγωγή νέου φύλλου στη θέση s (μετά το s - 1)

Worksheets.Add After:=Sheets(s - 1)

 

' Ονομασία Φύλλου s από το πρώτο κελί της στήλης j

Worksheets(s).Name = Worksheets(1).Cells(1, j)

 

' Γραμμή 2 (Φύλλο 1), Γραμμή 1 (Φύλλο s)

ia = 2

ib = 1

 

' Όσο δεν είναι κενό το κελί της γραμμής ia και της στήλης B του Φύλλου 1 επαναλαμβάνει

While Worksheets(1).Cells(ia, 2) <> ""

 

' Προσωρινή αποθήκευση του κελιού

temp = Worksheets(1).Cells(ia, j).Value

 

' Αν δεν είναι 0...

If temp <> 0 Then

 

' ...αντιγράφει στη γραμμή ib και τη στήλη C στο Φύλλο s τον τίτλο που βρίσκεται στη γραμμή ia και τη στήλη B του Φύλλου 1

Worksheets(s).Cells(ib, 3).Value = Worksheets(1).Cells(ia, 2).Value

 

' και στη γραμμή ib και τη στήλη H το προσωρινά αποθηκευμένο κελί

Worksheets(s).Cells(ib, 8).Value = temp

 

' Επόμενη γραμμή του Φύλλου s

ib = ib + 1

End If

 

' Επόμενη γραμμή του Φύλλου 1

ia = ia + 1

Wend

 

' Επόμενο φύλλο

s = s + 1

 

' Επόμενη στήλη

j = j + 1

Wend

End Sub

 

Από τον φίλο zefremi

http://www.freestuff...p=513762#513762

 

 

 

 

Φίλε Crizzt σ'ευχαριστώ για την απάντηση και την προσπάθεια σου! Νομίζω ότι είναι αρκετά χρήσιμο και θα ψάξω και την δικιά σου λύση...