[Excel07] πίνακες με συγχρονισμένη αλλαγή μεγέθους

[Spirosgr]

Λοιπόν Νικόλα, πάμε μεθοδικά να το κάνουμε σωστά.

Κατ' αρχάς θα πρέπει να κάνεις το βιβλίο .xlsm, για να δέχεται κώδικα.

Ο Πίνακας στο αγορα, έχει όνομα Πίνακας4, αλλά αυτό μπορεί να μην είναι το πραγματικό όνομα στο καλό βιβλίο σου.
Ο Πίνακας στο αποθήκη, έχει όνομα Πίνακας3, αλλά ούτε αυτό μπορεί να μην είναι το πραγματικό όνομα στο καλό βιβλίο σου.
Προς το παρών θα τους λέμε με αυτά τα ονόματα...

Πάμε στο αγορά και στον Πίνακα4, και ονομάζουμε την στήλη Κ (τεμάχια) = ColTarget

Πάμε στον κώδικα (Alt + F11) και στο φύλλο, αγορά αντιγράφουμε αυτό:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub

    Dim rng         As Range
    Set rng = Me.Range("ColTarget")

    If Intersect(Target, rng) Is Nothing Then Exit Sub

    ResizeTbl
End Sub

Βάζουμε μια module, και σε αυτήν αντιγράφουμε αυτό:

Sub ResizeTbl()
    Dim tbl1        As ListObject
    Dim tbl2        As ListObject
    'Όνομα πρώτου πίνακα στο αγορα
    Set tbl1 = Sheet1.ListObjects("Πίνακας4")
    'Όνομα δεύτερου πίνακα στο αποθηκη
    Set tbl2 = Sheet3.ListObjects("Πίνακας3")

    Dim strCol      As String
    Dim endCol      As String
    Dim c           As Long
    strCol = Split(tbl2.ListColumns(1).Range.Address, "$")(1)
    c = tbl2.DataBodyRange.Columns.Count
    endCol = Split(tbl2.ListColumns(c).Range.Address, "$")(1)

    Dim lRows       As Long
    lRows = tbl1.DataBodyRange.Rows.Count

    Dim HeadRow     As Long
    HeadRow = tbl2.HeaderRowRange.Row

    Dim tRow        As Byte
    Dim rRows       As Long
    On Error Resume Next
    tRow = tbl2.TotalsRowRange.Rows.Count
    On Error GoTo 0

    rRows = lRows + HeadRow + tRow

    tbl2.Resize Range(strCol & HeadRow & ":" & endCol & rRows)
End Sub

Τώρα
Στις θέσεις των ονομάτων πινάκων (κόκκινα)
βάζουμε τα πραγματικά ονόματα του «καλού» βιβλίου.
Στις θέσεις των ονομάτων φύλλων (μπλε)
βάζουμε τα πραγματικά κωδικά ονόματα των φύλλων του «καλού» βιβλίου.

Εκτέλεση
Βάζουμε στον Πίνακα 4, μια νέα γραμμή στο τέλος.
Πληκτρολογούμε ό,τι θέλουμε και
όταν πληκτρολογήσουμε στην στήλη Κ (ονομασμένη) , κάποια τεμάχια, τότε ο Πίνακας 3,
θα πάρει αυτόματα μια νέα γραμμή στο τέλος του.

Σημειώσεις
Προσθήκη νέας γραμμής στον 4, πάντα στο τέλος, πριν τα σύνολα
Προσθήκη αυτόματης γραμμής στον 3,
με την ολοκλήρωση πληκτρολόγησης στην στήλη Κ = ColTarget (Enter)
Το πόσες στήλες έχουν οι πίνακες, αδιάφορο (το χειρίζεται ο κώδικας)
Το αν έχουν γραμμή συνόλων, αδιάφορο (το χειρίζεται ο κώδικας)
Το αν υπάρχουν κι άλλοι πίνακες στα ίδια φύλλα, αδιάφορο

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

Δοκίμασε και τα λέμε...

[νικολας2000]

Αρχική Δημοσίευση από Spirosgr

Λοιπόν Νικόλα, πάμε μεθοδικά να το κάνουμε σωστά.

Κατ' αρχάς θα πρέπει να κάνεις το βιβλίο .xlsm, για να δέχεται κώδικα.

Ο Πίνακας στο αγορα, έχει όνομα Πίνακας4, αλλά αυτό μπορεί να μην είναι το πραγματικό όνομα στο καλό βιβλίο σου.
Ο Πίνακας στο αποθήκη, έχει όνομα Πίνακας3, αλλά ούτε αυτό μπορεί να μην είναι το πραγματικό όνομα στο καλό βιβλίο σου.
Προς το παρών θα τους λέμε με αυτά τα ονόματα...

Πάμε στο αγορά και στον Πίνακα4, και ονομάζουμε την στήλη Κ (τεμάχια) = ColTarget

Πάμε στον κώδικα (Alt + F11) και στο φύλλο, αγορά αντιγράφουμε αυτό:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub

    Dim rng         As Range
    Set rng = Me.Range("ColTarget")

    If Intersect(Target, rng) Is Nothing Then Exit Sub

    ResizeTbl
End Sub

Βάζουμε μια module, και σε αυτήν αντιγράφουμε αυτό:

Sub ResizeTbl()
    Dim tbl1        As ListObject
    Dim tbl2        As ListObject
    'Όνομα πρώτου πίνακα στο αγορα
    Set tbl1 = Sheet1.ListObjects("Πίνακας4")
    'Όνομα δεύτερου πίνακα στο αποθηκη
    Set tbl2 = Sheet3.ListObjects("Πίνακας3")

    Dim strCol      As String
    Dim endCol      As String
    Dim c           As Long
    strCol = Split(tbl2.ListColumns(1).Range.Address, "$")(1)
    c = tbl2.DataBodyRange.Columns.Count
    endCol = Split(tbl2.ListColumns(c).Range.Address, "$")(1)

    Dim lRows       As Long
    lRows = tbl1.DataBodyRange.Rows.Count

    Dim HeadRow     As Long
    HeadRow = tbl2.HeaderRowRange.Row

    Dim tRow        As Byte
    Dim rRows       As Long
    On Error Resume Next
    tRow = tbl2.TotalsRowRange.Rows.Count
    On Error GoTo 0

    rRows = lRows + HeadRow + tRow

    tbl2.Resize Range(strCol & HeadRow & ":" & endCol & rRows)
End Sub

Τώρα
Στις θέσεις των ονομάτων πινάκων (κόκκινα)
βάζουμε τα πραγματικά ονόματα του «καλού» βιβλίου.
Στις θέσεις των ονομάτων φύλλων (μπλε)
βάζουμε τα πραγματικά κωδικά ονόματα των φύλλων του «καλού» βιβλίου.

Εκτέλεση
Βάζουμε στον Πίνακα 4, μια νέα γραμμή στο τέλος.
Πληκτρολογούμε ό,τι θέλουμε και
όταν πληκτρολογήσουμε στην στήλη Κ (ονομασμένη) , κάποια τεμάχια, τότε ο Πίνακας 3,
θα πάρει αυτόματα μια νέα γραμμή στο τέλος του.

Σημειώσεις
Προσθήκη νέας γραμμής στον 4, πάντα στο τέλος, πριν τα σύνολα
Προσθήκη αυτόματης γραμμής στον 3,
με την ολοκλήρωση πληκτρολόγησης στην στήλη Κ = ColTarget (Enter)
Το πόσες στήλες έχουν οι πίνακες, αδιάφορο (το χειρίζεται ο κώδικας)
Το αν έχουν γραμμή συνόλων, αδιάφορο (το χειρίζεται ο κώδικας)
Το αν υπάρχουν κι άλλοι πίνακες στα ίδια φύλλα, αδιάφορο

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

Δοκίμασε και τα λέμε...

Δουλεύει άψογα..!!
Έχω την εντύπωση πως με κώδικα πολλαπλασιάζονται οι δυνατότητες στο excel.
Ευχαριστώ γισ την βοήθεια....!!!!!!

[Spirosgr]

Καλή συνέχεια, Νικόλα.