Need help with simple macro that I'm sure others would find useful!

[rexofspades]

Hi! I'm using Excel 2010 and I have a fairly straightforward issue that I'm trying to solve. Any help would be greatly appreciated! I'm a good programmer but I'm new to VBA, so I don't know enough syntax and it's taking me forever to do what I think should be pretty simple...

I have a To Do List I'm trying to build and I would like items that are "Done" to be first copied to a separate "Done" worksheet and then deleted from the To Do List.

From the "To Do List" worksheet, when a button is activated, it should search column B for a "P" (Wingdings 2 checkmark) and then copy the entire row, switch to the "Dones" worksheet, find the next empty row and copy the data in, thereby appending the list. Then it should delete the entire row completely. For bonus points: I really want TODAY() entered into column I on the "Dones" sheet for the new entries.

I would be so grateful for help!

 

[L. Howard]

Hi Howard! Thank you! Is that in lieu of Robert's suggestion? Robert's code worked very well. I'm just now trying to adapt it to paste values.

Thanks!

Addison

This should do it also.

Howard

Option Explicit

Sub P_Done_Date()

   Dim c As Range
Application.ScreenUpdating = False

   For Each c In Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row)
      
      If c.Value = "P" Then
        Range(c.Offset(, -1), c.End(xlToRight)).Copy
          Sheets("Done").Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
        Range(c.Offset(, -1), c.End(xlToRight)).ClearContents
        c.Offset(, -1) = Date
      End If
      
    Next 'c
    
    Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[rexofspades]

This should do it also.

Howard

Option Explicit

Sub P_Done_Date()

   Dim c As Range
Application.ScreenUpdating = False

   For Each c In Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row)
      
      If c.Value = "P" Then
        Range(c.Offset(, -1), c.End(xlToRight)).Copy
          Sheets("Done").Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
        Range(c.Offset(, -1), c.End(xlToRight)).ClearContents
        c.Offset(, -1) = Date
      End If
      
    Next 'c
    
    Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Hi - Thank you for that update. The issues I have with this is that it creates the date on the source sheet, where as I need it on the "Dones" sheet in column I.

Robert's code acheived this. Also, Robert's code moves all the checked items to the "Dones" tab with one click, whereas this macro requires one click per item. Perhaps you can just help me modify that so that it pastes values only. I've been fiddling with it for an hour but no luck:

    For Each rngMyCell In wsSourceTab.Range("B" & lngStartRow & ":B" & lngLastRow)
        If rngMyCell = "P" Then
            lngPasteRow = wsOutputTab.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            wsSourceTab.Rows(rngMyCell.Row).Copy Destination:=wsOutputTab.Range("A" & lngPasteRow)
            wsOutputTab.Range("I" & lngPasteRow) = Format(Now(), "mm/dd/yy") 'Today's date in 'dd/mm/yyyy' format. Change to suit.
            If rngDelRange Is Nothing Then
                Set rngDelRange = wsSourceTab.Cells(rngMyCell.Row, "A")
            Else
                Set rngDelRange = Union(rngDelRange, wsSourceTab.Cells(rngMyCell.Row, "A"))
            End If
        End If
    Next rngMyCell

 

[L. Howard]

Hi - Thank you for that update. The issues I have with this is that it creates the date on the source sheet, where as I need it on the "Dones" sheet in column I.

Robert's code acheived this. Also, Robert's code moves all the checked items to the "Dones" tab with one click, whereas this macro requires one click per item. Perhaps you can just help me modify that so that it pastes values only. I've been fiddling with it for an hour but no luck:

This should do the date in column I of Done sheet, sorry, I missed that, I didn't read thoroughly.

I don't understand the one click problem for each transfer. I run it on my test sheet and it transfers all "P" rows in a single operation of the code.

My test sheet is column A2 and down with Task 1, Task 2 etc. In column B there are intermittent "P"'s (Wingdings font, although the code recognizes with or with the wingdings font)

A single run does it on my sheet.

Howard

Option Explicit

Sub P_Done_Date()

   Dim c As Range
Application.ScreenUpdating = False

   For Each c In Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row)
      
      If c.Value = "P" Then
        Range(c.Offset(, -1), c.End(xlToRight)).Copy
           Sheets("Done").Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
           Sheets("Done").Range("A" & Rows.Count).End(xlUp).Offset(-1, 8)(2) = Date
       Range(c.Offset(, -1), c.End(xlToRight)).ClearContents
        
      End If
      
    Next 'c
    
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[L. Howard]

This modification to Robert's code works on my test sheet, for the values.

See the RED font code line.

Howard

Sub Macro1()

    Const lngStartRow As Long = 2 'Starting (static) row number for the data. Change to suit, if necessary.
    
    Dim lngLastRow As Long
    Dim lngPasteRow As Long
    Dim rngMyCell As Range
    Dim rngDelRange As Range
    Dim wsSourceTab As Worksheet
    Dim wsOutputTab As Worksheet
    
    Set wsSourceTab = Sheets("To Do List")
    Set wsOutputTab = Sheets("Done")
    
    lngLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    Application.ScreenUpdating = False
    
    For Each rngMyCell In wsSourceTab.Range("B" & lngStartRow & ":B" & lngLastRow)
        If rngMyCell = "P" Then
            lngPasteRow = wsOutputTab.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            wsSourceTab.Rows(rngMyCell.Row).Copy
            [COLOR="#FF0000"]wsOutputTab.Range("A" & lngPasteRow).PasteSpecial Paste:=xlPasteValues[/COLOR]
            wsOutputTab.Range("I" & lngPasteRow) = Format(Now(), "dd/mm/yyyy") 'Today's date in 'dd/mm/yyyy' format. Change to suit.
            If rngDelRange Is Nothing Then
                Set rngDelRange = wsSourceTab.Cells(rngMyCell.Row, "A")
            Else
                Set rngDelRange = Union(rngDelRange, wsSourceTab.Cells(rngMyCell.Row, "A"))
            End If
        End If
    Next rngMyCell
        
    'If the 'rngDelRange' range has been set, then...
    If Not rngDelRange Is Nothing Then
        '...delete the row(s) from it and inform the user
        rngDelRange.EntireRow.Delete
        MsgBox "All done entries marked with a tick have now been transferred to the """ & wsOutputTab.Name & """ tab.", vbInformation
    'Else...
    Else
        '...inform the user that no rows were deleted as there was no matching criteria in the dataset.
        MsgBox "There were no rows deleted as no there were no matching criteria.", vbExclamation
    End If
    
    Application.ScreenUpdating = True
        
    Set wsSourceTab = Nothing
    Set wsOutputTab = Nothing
        
End Sub

 

[rexofspades]

Hi Howard et. al,

Thank you very much for all your help with this macro. I was able to get it working late last night, though my code isn't as clean as yours. I really appreciate it - it's doing the job!!