将特定列值复制到另一个工作簿

Question

所以我有一个时间和动作研究跟踪器，带有开始、结束和提交按钮。我设法开始和结束。

但是我很难将特定数据复制到我的主文件中。在我的工作簿中，我有一个状态下拉选择。如果下拉列表的值为“待处理”，那么当我点击提交按钮时，这些案例应该在我的存档工作簿 Sheet1 中提交，最后一列中的状态将是更新为已提交。所以它会在我下次提交时排除这些情况，并且不应与主文件中的数据重叠。

有点迷失了 If 语句。

希望在各位大侠的帮助下解决这个问题

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

Answer 1

试试这个：

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

将特定列值复制到另一个工作簿

Copy Specific Column Values to another Workbook

excel

vba