在名为“ 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
答案 0 :(得分:-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)
。然后,在哪个表上创建地址都没有关系。