Макрос для копирования выбранного диапазона ячеек на другой лист в виде рисунка - PullRequest
Новая
       8

Макрос для копирования выбранного диапазона ячеек на другой лист в виде рисунка

0 голосов
/ 03 апреля 2020

Я использую следующий макрос для успешного копирования именованного диапазона ячеек с одного листа и вставки его в другой (активный лист) в качестве изображения с определенной шириной в ячейке на листе, которая определяется пользователем посредством ввода диалог. Я хочу закодировать аналогичную функцию копирования / вставки изображения, но вместо копирования именованного диапазона я хочу скопировать выбранный набор ячеек с листа активного листа на другой определенный лист. Буду признателен за любые рекомендации о том, как этого добиться. 

Sub Copy_Dock()  'Copy relevant Dock drawing range to Overview sheet</p>

<p>Dim dws, sws As Worksheet
Dim DrawingCode, swsName As String
Dim DockTopLeftCell As Range
Dim dTopLeftRow, dTopLeftColumn As Integer
Application.ScreenUpdating = False
Set dws = Worksheets("Overview")
ith dws</p>

<pre><code>''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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" & vbCr & _
                         "(DO NOT GO LESS THAN CELL U13)", _
                         "Dock drawing cell", "U13", Type:=8)
    If DockTopLeftCell Is Nothing Then Exit Sub
        dTopLeftRow = DockTopLeftCell.Row            ' Set dock drawing row origin
        dTopLeftColumn = DockTopLeftCell.Column      ' Set dock drawing column origin

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Determine Drawing Range Code
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

DrawingCode = "DOD11.2xOptions"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Determine Source Worksheet name (= DOD & Dock_Size value
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

swsName = "DOD11.2"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copy relevant dock drawing range to Overview sheet
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Worksheets(swsName).Range(DrawingCode).CopyPicture xlScreen, xlPicture
dws.Cells(dTopLeftRow, dTopLeftColumn).Select
dws.Paste
Selection.ShapeRange.LockAspectRatio = True
Selection.ShapeRange.Width = 420
</code>

End With End Sub

...