Copy Specific Column Values to another Workbook-CodePudding

So I have a time and motion study tracker with start, end and submit button button. I managed to worked on start and end.

But I am struggling to copy an specific data to my masterfile. In my workbook, I have a dropdown selection of status.. If the value of the dropdown is" Pending", then those cases should be submitted in my Archive workbook Sheet1 when I hit the Submit button and the status in my last column will be updated to Submitted. So it will exclude those cases on my next submission and should not overlap the data in master file.

Kinda lost with the If statement.

Hoping to solve this problem with the help from you guys.

Sub Submit()

Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Prod")


Dim Outapp As Object, Logfile As String

lr As Long, Archive As Workbook


sh = ThisWorkbook.Sheets("Prod")

Dim x As Integer
Dim i As Integer
Dim lastrow As Integer
Dim r As Long, lr As Long, Archive As Workbook

r = 2
lr = Cells(Rows.Count, 1).End(xlUp).Row

Set Archive = Workbook.Open("C:\Users\ChrisLacs\Desktop\Test\Archive.xlsm")

Do Until r = lr   2


lastrow = Application.WorksheetFunction.CountBlank(sh.Range("D:D"))

For x = 2 To lastrow

If sh.Range("O" & i).Value <> "Submitted" And sh.Range("J" & i).Value = "Pending" Then

Range(Cells(r, 1), Cells(r, 3)).Copy

Archive.Worksheets("Prod").Select
erow = Archive.Worksheets("Prod").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Archive.Worksheets("Prod").Rows(erow)

Range(Cells(r, 1), Cells(r, 4)).Value = ""

End If

r = r   1

Looop



Next

End Sub

CodePudding user response：

Try this out:

Sub Submit()
    Const WB_ARCH_PATH As String = "C:\Users\ChrisLacs\Desktop\Test\"
    Const WB_ARCH_NM As String = "Archive.xlsm """
    
    Dim wsSrc As Worksheet, r As Long, rw As Range, wbArch As Workbook
    Dim wsArch As Worksheet, cDest As Range
    
    Set wsSrc = ThisWorkbook.Sheets("Prod")  'source data sheet
    'open archive workbook if not already open
    On Error Resume Next                     'ignore error if not open
    Set wbArch = Workbooks(WB_ARCH_NM)
    On Error GoTo 0                          'stop ignoring errors
    If wbArch Is Nothing Then Set wbArch = Workbooks.Open(WB_ARCH_PATH & WB_ARCH_NM)
    Set wsArch = wbArch.Worksheets("Prod")
    Set cDest = wsArch.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) 'first paste destination
    
    For r = 2 To wsSrc.Cells(Rows.Count, "A").End(xlUp).Row   'loop source rows
        Set rw = wsSrc.Rows(r)
        If rw.Columns("O").Value <> "Submitted" And rw.Columns("J").Value = "Pending" Then
            rw.Cells(1).Resize(1, 3).Copy cDest  'Copy A:C for row `rw`
            rw.Columns("O").Value = "Submitted"  'update to Submitted
            Set cDest = cDest.Offset(1, 0)       'next paste destination
        End If
    Next r
    
    wbArch.Close True 'save changes
    
End Sub