Forum - VBA Λίστα ανά μήνα

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [VBA] Λίστα ανά μήνα (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/1661-lista-ana-mina.html)

Λίστα ανά μήνα

Παρακαλώ την βοήθειά σας.
Στο επισυναπτόμενο αρχείο στο φύλλο εργασίας (Data) καταγράφω κάποιες δραστηριότητες ενός μηνός.
Στο δεύτερο φύλλο εργασίας (Update) μεταφέρω τα δεδομένα εκάστου μηνός με VBA .

Κώδικας:

Sub Items_per_Month()
 

Dim LastCell As Range

     

     Application.ScreenUpdating = False

     Application.Goto Reference:="Data"

    Selection.Copy

     Sheets("Update").Select

    With ActiveSheet

    Set LastCell = .Cells(.Rows.Count, "B").End(xlUp)

    If IsEmpty(LastCell) Then

    Else

      Set LastCell = LastCell.Offset(1, 0)

    End If

  End With

    

    LastCell.Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

    Application.CutCopyMode = False

    LastCell(2).Select

End Sub

Με τον παραπάνω κώδικα τα δεδομένα εισάγονται στο πρώτο κενό κελί της στήλης Β (LastCell).
Το ζητούμενο είναι το κελί εισαγωγής των δεδομένων να προσδιορίζεται συγκρίνοντας το κελί (Α1) με την περιοχή κελιών (Month) και να επιλέγεται το πρώτο κελί δεξιά στην στήλη Β, καθώς επίσης αν υπάρχουν ήδη δεδομένα σ’ αυτό το κελί να βγαίνει προειδοποιητικό μήνυμα του τύπου Yes/No αν θέλουμε να γίνει η ενημέρωση η όχι.
Σας ευχαριστώ εκ των προτέρων
Γιώργος

Φίλε Γιώργο,
Ο παρακάτω κώδικας κάνει νομίζω αυτό που θέλεις.

Κώδικας:

Sub Copy_month()

Dim LastCell As Range

  Application.ScreenUpdating = False

  Range("Data").Copy

  With Sheets("Update")

    Set LastCell = .Cells(Range("Months").Row - 1 + _

      Application.WorksheetFunction.Match(Range("A1").Value, Range("Months"), 0), "B")

    If IsEmpty(LastCell.Value) Then

      LastCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _

        SkipBlanks:=False, Transpose:=False

    ElseIf MsgBox("Do you want to overwrite?", vbYesNo) = vbYes Then

      LastCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _

        SkipBlanks:=False, Transpose:=False

    End If

    Application.CutCopyMode = False

  End With

  LastCell.Select

  Application.ScreenUpdating = True

End Sub

Δοκίμασέ το και πες μας.
Θανάσης

Θανάση ευχαριστώ πολύ για την άμεση απάντηση:thanks:
Κάνει ακριβώς το ζητούμενο.
Και πάλι ευχαριστώ πολύ.
Γιώργος

Καλησπέρα!
Φίλε Γιώργο δοκίμασε:

Κώδικας:

Sub SetValues()

    Dim rng As Range, rng1 As Range

    Set rng = Range("Months").Find(Range("Months").Parent.Range("A1"), , xlValues)

    If Not rng Is Nothing Then

        Set rng = rng.Offset(, 1).Resize(1, Range("Data").Columns.Count)

        On Error Resume Next

        Set rng1 = rng.SpecialCells(xlCellTypeConstants)

        If Not rng1 Is Nothing Then

            If MsgBox("Ο μήνας " & rng.Offset(, -1)(1) & " περιέχει ήδη δεδομένα!" & vbLf & _

                      "Θέλετε να ενημερώσετε τα δεδομένα αυτά;", vbYesNo + vbQuestion) <> vbYes Then

                Exit Sub

            End If

        End If

        rng.Value = Range("Data").Value

    End If

End Sub

Καλή συνέχεια!

Τάσος

Θανάση με πρόλαβες!:dft009:

Τάσο σ ευχαριστώ κι εσένα
Το γεγονός ότι προλαβαίνει ο ένας τον άλλο δείχνει το μεγάλο ενδιαφέρον για τα προβλήματα των μέλων του Forum
Και πάλι σας ευχαριστώ
Γιώργος