[VBA] Λίστα ανά μήνα

[Flashgordon61]

Παρακαλώ την βοήθειά σας.
Στο επισυναπτόμενο αρχείο στο φύλλο εργασίας (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 αν θέλουμε να γίνει η ενημέρωση η όχι.
Σας ευχαριστώ εκ των προτέρων
Γιώργος

[gr8styl]

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

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

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

[Flashgordon61]

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

[Tasos]

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

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

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

Τάσος


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

[Flashgordon61]

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