Question

VBA代码从一个工作簿转移到另一个工作簿。例如，我有一个工作簿，每个部门有多个工作表。完成项目后，我手动复制并粘贴到已完成的工作簿。我需要帮助创建一个VBA代码，它只会将已完成的项目更新为已完成的主工作簿。我尝试了以下VBA代码，但它将所有工作表转移到一个工作表，这不是我想要的。

Sub SummurizeSheets()
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    Sheets("Sales").Activate
    For Each ws In Worksheets
        If ws.Name <> "Sales" Then
            ws.Range("A2:K45").Copy
            Worksheets("Sales").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
        End If
    Next ws
End Sub

如果单元格已完成，我需要单元格A2：I45 将已完成的项目复制到主工作簿。希望这是有道理的，否则我可以附上excel工作簿。因此，我为每个销售点提供了4个工作表。例如，工作表1是销售，然后是另一个Sales2 ...等...所有工作表包含相同的数据，但不同的部门区域编辑每个工作表，这就是为什么有多个工作表。一旦它们全部由每个部门完成，我希望这4个工作表转移到已完成工作簿中的一个工作表。

Answer 1

更新：

Sub SummarizeSheets()
    Dim ws As Worksheet, rw As Range, cDest As Range
    Dim wbDest As Workbook, wbSource As Workbook
    Dim rngSrc As Range, x As Long

    Set wbSource = ActiveWorkbook 'set source of data

    ' set the destination for completed items: adjust names to suit
    Set wbDest = Workbooks("Completed.xlsx") ' must be already open !
    Set cDest = wbDest.Worksheets("Complete").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

    Application.ScreenUpdating = False

    For Each ws In wbSource.Worksheets
        If ws.Name <> "Sales" Then
            Set rngSrc = ws.Range("A2:K45")
            ' step backwards since we might be deleting rows...
            For x = rngSrc.Rows.Count To 1 Step -1
                Set rw = rngSrc.Rows(x)
                If UCase(rw.Cells(1, "I").Value) = "COMPLETED" Then
                    cDest.Resize(1, rw.Columns.Count).Value = rw.Value
                    rw.EntireRow.Delete            'delete from source
                    Set cDest = cDest.Offset(1, 0) 'set next destination row
                End If
            Next x
        End If
    Next ws
End Sub

从一个工作簿转移到另一个工作簿

1 个答案: