cut and paste with command button into separate locations

[wheellp]

I am trying to cut and paste a row (and keeping the format) to another worksheet and 2 different worksheets in another workbook using a command button for rows in which column K shows a status of "Complete" and automatically save in both locations.

In Sheet 1 (Profile Requests in progress) I have data in columns A - M. Column K shows a status with a drop down list, "Complete" is selected from a drop down list currently.

I want my spreadsheet to cut and paste 'complete' rows into the next blank row on sheet 2 (2020 Completed) AND another workbook (Profile Request Tracker Report AUTO) in the sheets "Current Year Complete" and "All". The other workbook located in the following location L:\PROFILES\Reporting. Let me know if I can provide any more information. Thanks for any help!

 

[GWteB]

It is likely that the code below will do what you want. Nevertheless I would recommend that you try the code on copies of both affected workbooks.
Note the separate IsWorkbookOpen function on which the MoveCompleted procedure depends.

Public Function IsWorkbookOpen(argFullName As String) As Boolean

    Dim fileID As Long, errNum As Long

    fileID = FreeFile()
    On Error Resume Next
    Open argFullName For Input Lock Read As #fileID
    errNum = Err.Number
    Close fileID
    IsWorkbookOpen = CBool(errNum)
End Function


Public Sub MoveCompleted()

    Const cSrcSht       As String = "Profile Requests in progress"
    Const cDestSht      As String = "2020 Completed"
    Const cOtherWb      As String = "L:\PROFILES\Reporting\Profile Request Tracker Report AUTO.xlsx"
    Const cOtherShts    As String = "Current Year Complete:All"

    Dim oWsSrc As Worksheet, oWsDest1 As Worksheet, oWsDest2 As Worksheet, oWsDest3 As Worksheet
    Dim rng As Range, c As Range, x As Range, z As Range, vSht As Variant

    With ThisWorkbook
        Set oWsSrc = .Sheets(cSrcSht)
        Set oWsDest1 = .Sheets(cDestSht)
    End With

    vSht = Split(cOtherShts, ":")
    If IsWorkbookOpen(cOtherWb) Then
        Set oWsDest2 = Workbooks(Right(cOtherWb, (Len(cOtherWb) - InStrRev(cOtherWb, "\")))).Sheets(vSht(0))
    Else
        Set oWsDest2 = Workbooks.Open(cOtherWb).Sheets(vSht(0))
    End If
    Set oWsDest3 = oWsDest2.Parent.Sheets(vSht(1))

    With oWsSrc
        Set rng = .Range("K2:K" & .Cells(.Rows.Count, "K").End(xlUp).Row)
    End With

    For Each c In rng
        If StrComp(Trim(c.Text), "completed", vbTextCompare) = 0 Then
            Set x = c.Parent.Range("A" & c.Row & ":M" & c.Row)
            If Not z Is Nothing Then
                Set z = Application.Union(z, x)
            Else
                Set z = x
            End If
            With oWsDest1
                x.Copy .Range("A" & .Cells(.Rows.Count, "K").End(xlUp).Row + 1)
            End With
            With oWsDest2
                x.Copy .Range("A" & .Cells(.Rows.Count, "K").End(xlUp).Row + 1)
            End With
            With oWsDest3
                x.Copy .Range("A" & .Cells(.Rows.Count, "K").End(xlUp).Row + 1)
            End With
        End If
    Next c

    If Not z Is Nothing Then
        z.Delete Shift:=xlUp
    End If

    oWsSrc.Parent.Save
    oWsDest3.Parent.Save
End Sub

 

[wheellp]

I added a new module and updated the names for the copy version and getting a run time error. The debugger goes to line Set oWsDest2 = Workbooks(Right(cOtherWb, (Len(cOtherWb) - InStrRev(cOtherWb, "\")))).Sheets(vSht(0)). Suggestions on what I might change? Also for the ifworkbook open, does that mean both workbooks have to be open?

 

[GWteB]

.... getting a run time error. The debugger goes to line Set oWsDest2 = Workbooks(Right(cOtherWb, (Len(cOtherWb) - InStrRev(cOtherWb, "\")))).Sheets(vSht(0)).

There can be two causes:
- the cOtherWb constant does not consist of a path and file name, i.e. a backslash could not be found resulting in a workbook name which is NOT part of the workbooks collection;
- the vSht(0) variable does not evaluate to a valid or existing worksheet name of the workbook referred to with cOtherWb.

My code is based on your requirement:

I am trying to cut and paste a row (and keeping the format) to another worksheet and 2 different worksheets in another workbook

Those two different worksheet names are both assigned to the cOtherShts constant, separated with a colon ( : ), assuming they are both in the same workbook.
If the first worksheet name does not exist within the cOtherWb workbook, the code errors.

Also for the ifworkbook open, does that mean both workbooks have to be open?

Both the source and the destination workbook have to be open. The code assumes the source to be the workbook with the code in it, so that one is open.
The code line If IsWorkbookOpen(cOtherWb) Then checks whether the destination workbook is open or not.
If it's open it is part of the workbooks collection so a proper reference to the two requested worksheets can be made without further actions.
If that workbook is NOT open yet, it has to be opened before a proper reference to the two worksheets can be made.
Note that opening an already open workbook may cause unwanted data loss.

Without having seen the code modified by you, I cannot say with certainty whether the above list of causes is complete.

 

[wheellp]

I got it to work! Changed the path to an xlsm document. Is there a way to do this without having to have the other document open?

 

[GWteB]

Glad it's sorted!

Is there a way to do this without having to have the other document open?

To copy data from one workbook to another, both workbooks must be open. Of course you can close the target workbook afterwards using code, like

oWsDest3.Parent.Close

 

[wheellp]

Glad it's sorted!


To copy data from one workbook to another, both workbooks must be open. Of course you can close the target workbook afterwards using code, like

oWsDest3.Parent.Close

Quick question. What code can I add to the end to open, refresh all data in the work, save and close a 3rd workbook named "Profile Request Stats.xlsx" located at "L:\PROFILES\Reporting".

 

[GWteB]

Quick answer ....

    Dim oWb As Workbook, sFileName As String
    
    sFileName = "L:\PROFILES\Reporting\Profile Request Stats.xlsx"
    On Error Resume Next
    Set oWb = Workbooks.Open(sFileName)
    On Error GoTo 0
    If Not oWb Is Nothing Then
        
        ' >> do your stuff here <<
    
        oWb.Save
        oWb.Close
    End If

 

[wheellp]

In the overall code, What would I need to change for it to just paste values and formatting without any formulas? Or what might be a better formula to capture the date "complete" is marked? I am currently using the todays date formula =IF(K4="Complete",TODAY(),"")

 

[GWteB]

Have been offline awhile until now, so a delayed response...
Try replacing this:

    With oWsDest1
        x.Copy .Range("A" & .Cells(.Rows.Count, "K").End(xlUp).Row + 1)
    End With
    With oWsDest2
        x.Copy .Range("A" & .Cells(.Rows.Count, "K").End(xlUp).Row + 1)
    End With
    With oWsDest3
        x.Copy .Range("A" & .Cells(.Rows.Count, "K").End(xlUp).Row + 1)
    End With

with this:

    x.Copy

    Dim t As Range
    
    With oWsDest1
        Set t = .Range("A" & .Cells(.Rows.Count, "K").End(xlUp).Row + 1)
    End With
    t.PasteSpecial xlPasteAll
    t.PasteSpecial xlPasteValuesAndNumberFormats
    
    With oWsDest2
        Set t = .Range("A" & .Cells(.Rows.Count, "K").End(xlUp).Row + 1)
    End With
    t.PasteSpecial xlPasteAll
    t.PasteSpecial xlPasteValuesAndNumberFormats
    
    With oWsDest3
        Set t = .Range("A" & .Cells(.Rows.Count, "K").End(xlUp).Row + 1)
    End With
    t.PasteSpecial xlPasteAll
    t.PasteSpecial xlPasteValuesAndNumberFormats
    
    Application.CutCopyMode = False