excel - 将一个工作表中命名范围的单元格值复制到另一个工作表，从用户定义的单元格开始

Question

我有许多不同的单元格（每个单元格都分配了一个唯一的名称），它们位于名为“Master”的工作簿中包含的各种工作表中。要复制的源单元格是通过将它们的工作表和范围名称与目标工作簿中包含绘图代码的单元格的内容相匹配来选择的。以下宏专门将单元格“X6”定义为要在调用宏的目标工作表（“绘图”）中复制的单元格的起始单元格：

Option Explicit
Sub Copy_DOD()  'Copy specified named range

Dim dws, sws As Worksheet ' Destination and source worksheets
Dim swb As Workbook ' Source workbook
Dim DrawingCode, swsName As String 

Set dws = Worksheets("Drawing")
Set swb = Workbooks("Master.xlsm")

With dws

    Application.ScreenUpdating = False


    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Get Drawing Code
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    DrawingCode = dws.Range("DrawingCode")

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Determine Source Worksheet - DrawingCode up to character "x" 
    ' e.g code of 1234x56 produces worksheet name "1234" 
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    swsName = Left(DrawingCode, (InStr(DrawingCode, "x")) - 1)

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Copy Cells to Destination sheet
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''

   swb.Worksheets(swsName).Range(DrawingCode).Copy Range("X6")

End With

End Sub

我不想使用预定义的单元格（“X6”）作为要复制到的目标起始单元格，而是让用户指定起始单元格，而不是使用 InputBox。以下成功从用户那里获取指定的目标单元格，但在粘贴范围时失败。我知道我必须错误地定义粘贴，但无法弄清楚它需要什么。欢迎任何指导！

Option Explicit
Sub Copy_DOD()  'Copy specified named range

Dim dws, sws As Worksheet ' Destination and source worksheets
Dim swb As Workbook ' Source workbook
Dim DrawingCode, swsName As String 
Dim DockTopLeftCell As Range
Dim dTopLeftRow, dTopLeftColumn As Integer

Set dws = Worksheets("Drawing")
Set swb = Workbooks("Master.xlsm")

With dws

    Application.ScreenUpdating = False
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Get the top left cell for the dock drawing and determine row and column values
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

        On Error Resume Next
        Application.DisplayAlerts = False
        Set DockTopLeftCell = (Application.InputBox("Enter the cell to be the top left corner of the dock drawing (DO NOT GO LESS THAN CELL X6)", Type:=8))
        Application.DisplayAlerts = True
        On Error GoTo 0
        If DockTopLeftCell Is Nothing Then Exit Sub
            dTopLeftRow = DockTopLeftCell.Row            ' Set dock drawing row origin
            dTopLeftColumn = DockTopLeftCell.Column      ' Set dock drawing column origin

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Get Drawing Code
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    DrawingCode = dws.Range("DrawingCode")

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Determine Source Worksheet - DrawingCode up to character "x" 
    ' e.g code of 1234x56 produces worksheet name "1234" 
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    swsName = Left(DrawingCode, (InStr(DrawingCode, "x")) - 1)

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Copy Cells to Destination sheet
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    swb.Worksheets(swsName).Range(DrawingCode).Copy Range(DockTopLeftCell)
    'swb.Worksheets(swsName).Range(DrawingCode).Copy Range("X6")

End With

End Sub

标签： excelvba

Answer 1

我已经审查、更正并评论了您的代码。这是我工作的成果。

Sub Copy_DOD_2()  'Copy specified named range

    Dim sWb As Workbook                         ' Source workbook
    ' if no data type is prescribed VBA assumes Variant
    ' VBA does NOT assume the data type specified for the
    ' last item in a line.
    Dim dWs As Worksheet, sWs As Worksheet      ' Destination and source worksheets
    Dim DrawingCode As String, sWsName As String
    Dim DockTopLeftCell As Range
'    Dim dTopLeftRow As Long, dTopLeftColumn As Long

    Set sWb = Workbooks("Master.xlsm")
    Set dWs = Worksheets("Drawing")         ' this Ws is in the ActiveWorkbook
                                            ' maybe "Master", perhaps another

    Application.ScreenUpdating = False

    With dWs

        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' Get the top left cell for the dock drawing and determine row and column values
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' Application Alerts provide useful help in this case.
        On Error Resume Next
        Set DockTopLeftCell = Application.InputBox( _
                             "Enter the cell to be the top left corner " & _
                             "of the dock drawing" & vbCr & _
                             "(DO NOT GO LESS THAN CELL X6)", _
                             "Dock drawing cell", "X6", Type:=8)
        If DockTopLeftCell Is Nothing Then Exit Sub

        On Error GoTo 0
'            dTopLeftRow = DockTopLeftCell.Row            ' Set dock drawing row origin
'            dTopLeftColumn = DockTopLeftCell.Column      ' Set dock drawing column origin

        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' Get Drawing Code
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

        DrawingCode = dWs.Range("DrawingCode").Value

        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' Determine Source Worksheet - DrawingCode up to character "x"
        ' e.g code of 1234x56 produces worksheet name "1234"
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

        sWsName = Left(DrawingCode, (InStr(DrawingCode, "x")) - 1)

        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' Copy Cells to Destination sheet
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''

        sWb.Worksheets(sWsName).Range(DrawingCode).Copy DockTopLeftCell
        'swb.Worksheets(swsName).Range(DrawingCode).Copy Range("X6")

    End With

    Application.ScreenUpdating = True
End Sub

错误似乎DockTopLeftCell已经是一个范围。因此Range(DockTopLeftCell)必然失败。但是，我想提醒您注意指定范围的位置。Type 8 InputBox 大概定义了当前 ActiveSheet 上的范围。您的代码中没有证据表明可能是哪张表。因此，您可能会对副本的最终位置感到惊讶。

我可能会获取指定单元格的地址并在我想要的工作表上使用它，例如Set DockTopLeftCell = MySheet.Range(DockTopLeftCell.Address). 那么地址是在哪张纸上创建的就无关紧要了。