Question

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

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

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。但是，我绕过了新工作簿的整个激活，因为它需要你然后重新激活＆＃34;复制下一行之前的原始工作簿。否则，您将从活动工作簿复制，现在将是要粘贴的工作簿。请参阅代码 - 它应该相当简单。

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

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

1 个答案: