Αυτόματη αντιγραφή κελιών σε Excel με Visual Basic

[apok]

Ερώτησις προς εξελάκηδες

Εχω σε ένα excel δυο Sheets
Sheet1= Pricelist ( βάζω sku/ τιμές κτλ )
Sheet2= Στοιχεία απο το sheet1 ( ο,τι χρειάζομαι απο αυτά ) και PrintAreas για να το "κλείνω" .PDF για να στέλνω προσφορά.

Πως γίνεται το sheet2 να παίρνει αυτόματα ο,τι περνάω στο sheet1 χωρίς να χρειάζεται να προσθαφαιρώ γραμμές;

Ρώτησα τον κύριο GPT και μου εδωσε ένα κώδικα αλλά μάλλον ήταν GTP ο κώδικας

Spoiler:

Sub UpdateRows()
    Dim sourceSheet As Worksheet
    Dim destSheet As Worksheet
    Dim lastRowSource As Long
    Dim lastRowDest As Long
    Dim i As Long

    ' Set the source and destination sheets
    Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
    Set destSheet = ThisWorkbook.Worksheets("Sheet2")

    ' Find the last used row in the source sheet
    lastRowSource = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row

    ' Find the last used row in the destination sheet
    lastRowDest = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row

    ' Loop through the rows in the source sheet
    For i = 2 To lastRowSource
        ' Check if the value in column A of the source sheet exists in the destination sheet
        If WorksheetFunction.CountIf(destSheet.Range("A:A"), sourceSheet.Cells(i, "A").Value) = 0 Then
            ' Copy the row from the source sheet to the destination sheet
            sourceSheet.Rows(i).Copy destSheet.Rows(lastRowDest + 1)
            lastRowDest = lastRowDest + 1
        Else
            ' Update the existing row in the destination sheet
            destSheet.Rows(WorksheetFunction.Match(sourceSheet.Cells(i, "A").Value, destSheet.Range("A:A"), 0)).Value = sourceSheet.Rows(i).Value
        End If
    Next i

    ' Clean up
    Set sourceSheet = Nothing
    Set destSheet = Nothing
End Sub

Καμία άλλη ιδέα ;

[ipo]

Αν το πλήθος των γραμμών στο εξαγόμενο φύλλο είναι πάντα πάντα μεγαλύτερο ή ίσο του πλήθους των γραμμών του πηγαίου φύλλου, δεν σε εξυπηρετεί;

Π.χ. μπορείς να σβήνεις τις κενές γραμμές στο shit 2 πριν το πιντιέφιασμα και να τις επαναφέρεις μετά με αντού.

[apok]

Αν το πλήθος των γραμμών στο εξαγόμενο φύλλο είναι πάντα πάντα μεγαλύτερο ή ίσο του πλήθους των γραμμών του πηγαίου φύλλου, δεν σε εξυπηρετεί;

Π.χ. μπορείς να σβήνεις τις κενές γραμμές στο shit 2 πριν το πιντιέφιασμα και να τις επαναφέρεις μετά με αντού.

Όχι γιατί κάθε μέρα κάνω αρκετές προσφορές και με αυτό χάνω χρόνο στο να βαζωβγάζω γραμμές ανάλογα με το πλήθος των προϊόντων στην προσφορά.

[ipo]

Πιθανώς να χρειάζεται λύση με κώδικα, όπως σου είπε το ChatGPT.

Λύση με κώδικα σε Google Sheets σε βολεύει να κοιτάξω μπας και βρω κατιτίς; Έχω λίγο εξοικείωση με την Apps Script, ενώ με τη Visual Basic δεν το 'χω τόσο.

[harris]

Ερώτησις προς εξελάκηδες

Εχω σε ένα excel δυο Sheets
Sheet1= Pricelist ( βάζω sku/ τιμές κτλ )
Sheet2= Στοιχεία απο το sheet1 ( ο,τι χρειάζομαι απο αυτά ) και PrintAreas για να το "κλείνω" .PDF για να στέλνω προσφορά.

Πως γίνεται το sheet2 να παίρνει αυτόματα ο,τι περνάω στο sheet1 χωρίς να χρειάζεται να προσθαφαιρώ γραμμές;

Καμία άλλη ιδέα ;

Στο κελί του δεύτερου φύλλου, αντί να βάζεις με το χέρι τις τιμές, συνδέεις το κελί με το κελί του πρώτου φύλλου. Διπλό κλικ στο κελί στο δεύτερο φύλλο, πατάς το = και μετά, όπως είναι ενεργό το κελί, πατάς το πρώτο φύλλο, πατάς το κελί που έχει την τιμή, και έντερ... Ότι τιμή έχει το κελί στο πρώτο φύλλο θα έχει και το κελί στο δεύτερο. Είτε αυτό είναι αριθμός, είτε γράμματα είτε οτιδήποτε.

Αν δεν είναι κατανοητό αυτό που γράφω, πάρε με τηλέφωνο.

[ipo]

harris, ανέφερε ότι έχει μεταβλητό πλήθος γραμμών στο Sheet1 και θέλει αυτό το πλήθος να αντικατοπτρίζεται αυτόματα στο Sheet2 για λόγους μορφοποίησης του εξαγόμενου πιντιέφιου.

[harris]

harris, ανέφερε ότι έχει μεταβλητό πλήθος γραμμών στο Sheet1 και θέλει αυτό το πλήθος να αντικατοπτρίζεται αυτόματα στο Sheet2 για λόγους μορφοποίησης του εξαγόμενου πιντιέφιου.

Ναι ρε συ. Αλλάζει τις μεταβλητές στο πρώτο φύλλο και φαίνονται στο δεύτερο με τον τρόπο που είπα...

[ipo]

Ναι ρε συ. Αλλάζει τις μεταβλητές στο πρώτο φύλλο και φαίνονται στο δεύτερο με τον τρόπο που είπα...

Περίπτωση 1: 10 γραμμές στο πρώτο φύλλο. Επομένως προσαρμόζει το δεύτερο φύλλο να δείχνει 10 γραμμές επίσης.

10 λεπτά μετά, παρουσιάζεται η περίπτωση 2, την οποία θέλει να χειριστεί αυτόματα: 5 γραμμές στο πρώτο φύλλο. Στο δεύτερο φύλλο αυτόματα θα εμφανιστούν οι 5 γραμμές με τα στοιχεία τους από το πρώτο φύλλο, αλλά θα παραμείνουν και άλλες 5 κενές. Μπορεί να σβήσει/κρύψει τις γραμμές χειροκίνητα, αλλά ανέφερε ότι δεν θέλει να αφιερώνει τον χρόνο γι' αυτή την ενεργεία.

Σκέφτομαι να φτιάξω κάποια συνάρτηση που να κρύβει αυτόματα στο δεύτερο φύλλο τις κενές γραμμές, αν δεν υπάρχει έτοιμη λύση.

- - - Updated - - -

apok, δοκίμασε αν σε καλύπτει η ακόλουθη λύση. Κατ' αρχάς θεωρώ ότι αυτό που σε ενοχλεί είναι μόνο οι γραμμές. Αν θέλεις να κρύψεις και στήλες, κατά περίπτωση, πρέπει να δούμε άλλη λύση.

- Φτιάχνεις Sheet1 με το μέγιστο πλήθος γραμμών. Π.χ. υπολογίζεις ότι υπάρχει περίπτωση να έχεις κατά μέγιστο 100 γραμμές.
- Φτιάχνεις το Sheet2 να αντιστοιχεί σε όλες τις γραμμές του Sheet1. Συγκεκριμένα πας στο κελί A1 του Sheet2 και γράφεις:
=Sheet1!A1
- Τραβάς το περιεχόμενο του πρώτου κελιού του Sheet2 (left mouse button drag) στις άλλες στήλες και γραμμές, ώστε να συμπληρωθεί αντίστοιχα.
- Επιλέγεις την πρώτη γραμμή στο Sheet2.
- Από το μενού (ribbon) πας Data -> Filter
- Με το παραπάνω εμφανίζεται drop down menu στην πρώτη γραμμή. Πατάς στο βελάκι drop down και επιλέγεις τα πάντα εκτός από το #REF!
Έτσι θα κρύβονται οι γραμμές που εμφανίζουν το παραπάνω σφάλμα απουσίας τιμής αναφοράς (#REF!) στο Sheet2 και θα εμφανίζονται μόνο αυτές που θέλεις.

[apok]

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

Θα κοιτάξω λιγο τον κώδικα ( αν και δεν μου έβγαλε κάποιο λάθος οταν τον έτρεξα ) για ποιο λόγο δεν αντικατοπτρίζει σωστά τις τιμές του sheet1 στο sheet2

Είχα βάλει και button να κάνει refresh ... τοσο σίγουρος ήμουν

[ipo]

apok, πες μου σε ποιο σημείο σού λείπει αυτοματισμός, στην τελευταία πρότασή μου με το φίλτρο, ίσως μπορώ να το βελτιώσω.

Αν θέλεις, μπορείς να μου δώσεις δύο δείγματα περιπτώσεων, ώστε να δω τις διαφορές τους και να προσπαθήσω να προβλέψω την προβολή.

[apok]

Ιπε κατ αρχάς σε ευχαριστώ που ασχολείσαι τοσο

Κατά δεύτερον απο τη στιγμή του "Από το μενού (ribbon) πας Data -> Filter" χάνεται ο αυτοματισμός και θέλει να χεράτη επέμβαση και αυτο θέλω να αποφύγω
Επίσης έχω ένα Product list με 625 SKU's.
Αλλο excel φτιάχνω για πελάτη λιανικής
Αλλο για πελάτη χονδρικής
Άλλο για reseller
κοκ

Για αυτό θέλω ένα αρχείο όπου εχω 4 sheets
a) Proposal ( εδώ βάζω τα SKU's )
b) Print_OUT ( οτι βάζω στο Α, αλλά σε print_out μορφή )
c) Data ( απο εδώ τραβάει data to Α.. με vlookup παίρνει απο εδώ ανάλογα με το SKU, την περιγραφή, και την τιμή )
d) Availability ( και πάλι το A τραβάει απο εδώ data για το SKU σε τι status ειναι ... Available, On Allocation, TBA )

Προς το παρόν το κάνω χεράτα το "Β" ...πρσθέτω γραμμές αντίστοιχες με το Α και βάζω τους τύπους =sheet!B1,C1,D1 κοκ

Θέλω ομως αυτό να γίνεται auto update

Το είχα κάνει πιο παλιά οπότε τώρα πρέπει να βρω πάλι τον τρόπο...

[ipo]

Με το φίλτρο, νομίζω ότι χρειάζεται μετά την αλλαγή, select all και κατόπιν αποεπιλογή των κενών. Νομίζω ότι είναι πιο εύκολο έτσι.

---------------------------------------------------------

Γίνεται όμως και με Visual Basic:

https://www.youtube.com/watch?v=1B3iv-lNw5k

Απλά άλλαξα τον κώδικα ως εξής, διότι του tutorial δεν μου έπαιζε σωστά. Το range θα πρέπει να αλλάξεις, ανάλογα με το πλήθος των στηλών, διότι έχω βάλει δύο στήλες στο παράδειγμα.

Sub copyNonBlankData()
    Dim erow As Long, lastrow As Long, i As Long
    Dim pasteRow As Long
    
    lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    pasteRow = 1 ' Start pasting from the first row in Sheet2
    
    For i = 1 To lastrow
        If Sheet1.Cells(i, 1) <> "" Then
            Sheets("Sheet1").Range(Sheets("Sheet1").Cells(i, 1), Sheets("Sheet1").Cells(i, 2)).Copy
            Sheets("Sheet2").Activate
            erow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
            ActiveSheet.Paste Destination:=Sheets("Sheet2").Range(Cells(pasteRow, 1), Cells(pasteRow, 2))
            pasteRow = pasteRow + 1 ' Increment pasteRow for the next paste
            Sheets("Sheet1").Activate
        End If
    Next i
    
    Application.CutCopyMode = False
End Sub

[apok]

Με το φίλτρο, νομίζω ότι χρειάζεται μετά την αλλαγή, select all και κατόπιν αφαίρεση αποεπιλογή των κενών. Νομίζω ότι είναι πιο εύκολο έτσι.

Γίνεται και με Visual Basic:

https://www.youtube.com/watch?v=1B3iv-lNw5k

Απλά άλλαξα τον κώδικα ως εξής, διότι του tutorial δεν μου έπαιζε σωστά. Το range θα πρέπει να αλλάξεις, ανάλογα με το πλήθος των στηλών, διότι έχω βάλει δύο στήλες στο παράδειγμα.

Sub copyNonBlankData()
    Dim erow As Long, lastrow As Long, i As Long
    Dim pasteRow As Long
    
    lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    pasteRow = 1 ' Start pasting from the first row in Sheet2
    
    For i = 1 To lastrow
        If Sheet1.Cells(i, 1) <> "" Then
            Sheets("Sheet1").Range(Sheets("Sheet1").Cells(i, 1), Sheets("Sheet1").Cells(i, 2)).Copy
            Sheets("Sheet2").Activate
            erow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
            ActiveSheet.Paste Destination:=Sheets("Sheet2").Range(Cells(pasteRow, 1), Cells(pasteRow, 2))
            pasteRow = pasteRow + 1 ' Increment pasteRow for the next paste
            Sheets("Sheet1").Activate
        End If
    Next i
    
    Application.CutCopyMode = False
End Sub

Αυτό βρηκα και εγώ και ερχόμουν να σας δώσω το update

Σε ευχαριστώ πολύ πολύ ίπε

[ipo]

Φίλτρο ή Visual Basic χρησιμοποίησες τελικά;

[apok]

Φίλτρο ή Visual Basic χρησιμοποίησες τελικά;

Vb

Τα φιλτρα ειναι ξεπερασμένα