从当前工作簿复制数据并将其粘贴到具有用户表单列表的另一个打开的工作簿

时间:2014-12-04 11:04:30

标签: excel excel-vba vba

我想要一个按钮打开一个包含所有打开的工作簿列表的用户窗体。用户选择他们想要的工作簿,代码从当前工作簿中的固定范围复制数据,并将其粘贴到用户选定工作簿的固定范围内。

在搜索时我发现了这个代码,它的工作方式类似,但是从选定的工作簿复制并粘贴到当前的工作簿中。

Option Explicit
Const PSWD = "atari"

Private Sub CancelButton_Click()
    Unload Me
End Sub
Private Sub CopyPasteButton_Click()

    ActiveSheet.Unprotect Password:=PSWD
    'This code will be executed when the "Copy" button is clicked on the userform.
    Dim wsData As Worksheet
    Dim rCopy As Range
    Dim CopyRw As Long

    Set wsData = ThisWorkbook.Sheets("SALES Details")

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = True

        With wsData
            .Unprotect PSWD
            CopyRw = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End With

        On Error GoTo exit_err

        With Workbooks(Me.ListBox1.Value).Sheets("Master Sheet")
            Set rCopy = .Cells(10, 1).CurrentRegion
            Set rCopy = rCopy.Offset(1, 0).Resize(rCopy.Rows.Count - 1, 40)
            rCopy.Copy ThisWorkbook.Sheets("SALES Details").Cells(CopyRw, 1)
        End With

        Unload Me

exit_err:
        wsData.Protect Password:=PSWD
        .DisplayAlerts = True
        .ScreenUpdating = True
        .CutCopyMode = False
    End With
End Sub

Private Sub UserForm_Activate()

'Populate list box with names of open workbooks, excluding main workbook.

    Dim wb As Workbook

    For Each wb In Workbooks
        If wb.Name <> ThisWorkbook.Name Then ListBox1.AddItem wb.Name
    Next wb

End Sub

这段代码非常适用于它的功能。我一直试图编辑它没有运气。如何编辑此项以反转方向并将其从当前工作表(A50:J57)中的固定范围复制到用户所选工作表(A4:J11)上的固定范围?

1 个答案:

答案 0 :(得分:1)

我认为这应该有效。当然,您必须在代码中调整工作表名称。

Private Sub CopyPasteButton_Click()
    Dim mySheet As Worksheet, otherSheet As Worksheet

    On Error GoTo exit_err

    Application.DisplayAlerts = False

    Set mySheet = ThisWorkbook.Sheets("SheetXYZ")
    Set otherSheet = Workbooks(Me.ListBox1.Value).Sheets("SheetABC")

    mySheet.Range("A50:J57").Copy Destination:=otherSheet.Range("A4:J11")

exit_err:
    Application.DisplayAlerts = True
End Sub

更新

要复制值而不是范围的公式,请使用此代码而不是复制功能:

mySheet.Range("A50:J57").Copy 
otherSheet.Range("A4:J11").PasteSpecial xlPasteValuesAndNumberFormats

有关PasteSpecial功能的更多选项,请参阅documentation