将数据复制到另一个工作簿

Question

我使用了两个工作簿（显然是基于问题:)），第一个工作簿（正如您将在下面的代码中看到的那样）按列 "B" 中的数据排序。此列中的数据只是基于月份的数字（11=11 月，12 月=12，等等）。对于这个问题（它会为我的其他每月工作簿提供答案），需要将B列中的所有数据行（列A:AE）复制到另一个工作簿（已经打开），并粘贴数据进入底部的空行。我的排序部分工作正常。我正在尝试将复制和粘贴功能添加到代码中，但无法使其正常工作。帮助！

这是我试过的代码（但无法弄清楚如何将焦点放在目标工作簿上）：

Sub Extract_Sort_1512_December()
' This line renames the worksheet to "Extract"
Application.ScreenUpdating = False
    ActiveSheet.Name = "Extract"

' This line autofits the columns C, D, O, and P
    Range("C:C,D:D,O:O,P:P").Columns.AutoFit

' This unhides any hidden rows
    Cells.EntireRow.Hidden = False

Dim LR As Long

With ActiveWorkbook.Worksheets("Extract").Sort
    With .SortFields
        .Clear
        .Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

    End With
    .SetRange Range("A2:Z2000")
    .Apply
End With

    For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("B" & LR).Value <> "12" Then
            Rows(LR).EntireRow.Hidden = True
        End If
    Next LR

Cells.WrapText = False
Sheets("Extract").Range("A2").Select

Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row

    For i = 2 To LastRow
        If Cells(i, 2) = “12” Then
        Range(Cells(i, 1), Cells(i, 31)).Select
        Selection.Copy

        ActiveWorkbook(“Master File - Swivel - December 2015.xlsm”).Select
        Worksheets(“Master”).Select
        erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

        ActiveSheet.Cells(erow, 1).Select
        ActiveSheet.Paste
        End If
    Next i

Application.ScreenUpdating = True
End Sub

我在下面找到了这段代码，但不知道如何将它正确地插入到我上面的代码中。让我感到疲倦的是工作簿已经打开了。目标工作簿位于我们的 SharePoint 网站上，我不知道您如何（或是否）可以使用 VBA 代码将其打开到您的桌面。

这是另一个代码：

Sub Demo()

    Dim wbSource As Workbook
    Dim wbTarget As Workbook

    ' First open both workbooks :
    Set wbSource = Workbooks.Open("  ") ' <<< path to source workbook
    Set wbTarget = ActiveWorkbook ' Workbooks.Open("  ") ' <<< path to destination workbook

    'Now, transfer values from wbSource to wbTarget:
    wbTarget.Sheets("Sheet1").Range("B2").Value = wbSource.Sheets("Sheet3").Range("H4")
    wbTarget.Sheets("Sheet1").Range("B3").Value = wbSource.Sheets("Sheet3").Range("J10")

    'Close source:
    wbSource.Close

End Sub

Answer 1

我稍微修改了你的代码，但大部分保持原样。

我认为问题与您尝试激活要粘贴数据的工作簿的方式有关。通常 Activate 命令与工作簿一起使用，而不是 Select。但是，我绕过了新工作簿的整个激活过程，因为它要求您在复制下一行之前 "re-activate" 原始工作簿。否则，您将从活动工作簿中复制，而现在将是要粘贴到的工作簿。请查看代码 - 它应该相当简单。

Sub Extract_Sort_1512_December()

    Application.ScreenUpdating = False

    ' This line renames the worksheet to "Extract"
    ActiveSheet.Name = "Extract"

    ' This line autofits the columns C, D, O, and P
    Range("C:C,D:D,O:O,P:P").Columns.AutoFit

    ' This unhides any hidden rows
    Cells.EntireRow.Hidden = False

    Dim LR As Long

    With ActiveWorkbook.Worksheets("Extract").Sort
        With .SortFields
            .Clear
            .Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        End With
        .SetRange Range("A2:Z2000")
        .Apply
    End With

    For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Not Range("B" & LR).Value = "12" Then
            Rows(LR).EntireRow.Hidden = True
        End If
    Next LR

    Cells.WrapText = False
    Sheets("Extract").Range("A2").Select

    Dim LastRow As Integer, i As Integer, erow As Integer

    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LastRow
        If Cells(i, 2) = "12" Then

            ' As opposed to selecting the cells, I just copy them directly
            Range(Cells(i, 1), Cells(i, 31)).Copy

            ' As opposed to "Activating" the workbook, and selecting the sheet, I just paste the cells directly
            With Workbooks("Master File - Swivel - December 2015.xlsm").Sheets("Master")
                erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                .Cells(erow, 1).PasteSpecial xlPasteAll
            End With

            Application.CutCopyMode = False

        End If
    Next i

    Application.ScreenUpdating = True

End Sub

将数据复制到另一个工作簿

Copying Data to another workbook

excel

vba

excel-2007