Вырезать / вставить диапазон ячеек в другой лист и отправить электронное письмо

Question

У меня есть код, который работает почти так же, как я хотел бы, ниже.На данный момент у меня есть два листа: один для Y-отдела и один для X-отдела.Мне нужна кнопка для передачи диапазона ячеек (A: L) от листа Y-отдела к листу X-отдела.Я не хочу вставлять всю строку, потому что на листе X-отдела есть формулы из MW, которые перезаписываются, когда я делаю это.

На данный момент это почти работает.Но это позволяет мне проходить только один ряд за раз.Можно ли редактировать этот код так, чтобы я мог выбрать более одной строки за раз, и он будет вырезать и вставить (только ячейки A: L of) все эти строки на лист X-отдела?

Заранее спасибо!

Sub Pass_to_Xdepartment()

If MsgBox("Do you want to pass the selected tours to Xdepartment?", vbYesNo, "Pass to XDepartment") = vbNo Then Exit Sub

For Each WSheet In ActiveWorkbook.Worksheets
        If WSheet.AutoFilterMode Then
            If WSheet.FilterMode Then
                WSheet.ShowAllData
            End If
        End If
        For Each DTable In WSheet.ListObjects
            If DTable.ShowAutoFilter Then
                DTable.Range.AutoFilter
                DTable.Range.AutoFilter
            End If
        Next DTable
    Next WSheet

'Declare variables
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim lastRow As Long

'Set variables
    Set sht1 = Sheets("YDepartment")
    Set sht2 = Sheets("XDepartment")

'Select Entire Row
    Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row).Select

'Move row to destination sheet & Delete source row
    lastRow = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row

    With Selection
        .Copy Destination:=sht2.Range("A" & lastRow + 1)
        .EntireRow.Delete
    End With

End Sub

Кроме того, вы не знаете, есть ли способ настроить эту кнопку так, чтобы она отправляла электронное письмо одновременно с передачей данных для уведомления X-отдел, когда ряды были переданы на их лист?Это второстепенная проблема.

Answer 1

Некоторые предложения, некоторые «должны иметь» :

1. Избегайте использования Select в Excel VBA

2. Очевидно, Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row) - это только одна строка, потому что ActiveCell - это одна ячейка, а не диапазон ячеек.Если вы хотите получить столбцы от A до L выбранного диапазона, используйте…

   Selection.EntireRow.Resize(ColumnSize:=12) '= first 12 columns of selection
   

3. Все ваши Range и Cells должны быть указаны с листом, подобным sht1.Range.

4. Используйте значимые имена переменных, например, замените sht1 на wsSource и sht2 на wsDestination, что делает ваш код намного проще для понимания.

5. Не проверяйте окно сообщения, например If MsgBox(…) = vbNo Then, вместо этого проверяйте If Not MsgBox(…) = vbYes.В противном случае нажатие X в правом верхнем углу окна будет иметь тот же эффект, что и нажатие кнопки Да .

6. Убедитесь, что вы действительноозначает ActiveWorkbook (= тот, который имеет фокус / находится сверху), а не ThisWorkbook (= тот, в котором работает этот код).

7. Я рекомендую активировать Option Explicit: В редакторе VBA перейдите на Инструменты › Параметры › Требуется объявление переменных и объявите все вашипеременные правильно.

Таким образом, вы получите что-то вроде:

Option Explicit

Public Sub Pass_to_Xdepartment()
    If Not MsgBox("Do you want to pass the selected tours to Xdepartment?", vbYesNo, "Pass to XDepartment") = vbYes Then
        Exit Sub
    End If

    Dim ws As Worksheet, DTable As ListObject
    For Each ws In ThisWorkbook.Worksheets
        If ws.AutoFilterMode Then
            If ws.FilterMode Then
                ws.ShowAllData
            End If
        End If
        For Each DTable In ws.ListObjects
            If DTable.ShowAutoFilter Then
                DTable.Range.AutoFilter
                DTable.Range.AutoFilter
            End If
        Next DTable
    Next ws

    Dim wsSrc As Worksheet
    Set wsSrc = ThisWorkbook.Worksheets("YDepartment")

    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Worksheets("XDepartment")

    Dim LastRow As Long
    LastRow = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row

    'Move row to destination sheet & Delete source row
    With Selection.EntireRow.Resize(ColumnSize:=12) '= A:L of the selected rows
        .Copy Destination:=wsDest.Cells(LastRow + 1, "A")
        .EntireRow.Delete
    End With
End Sub

---

Редактировать в соответствии с комментариями (дата записи):

Так как вы все равно удалите скопированные строки, вы можете сначала записать дату в столбец M

    Intersect(Selection.EntireRow, Selection.Parent.Columns("M")).Value = Date

, а затем скопировать A: M вместо A: L

    With Intersect(Selection.EntireRow, Selection.Parent.Range("A:M")) '= A:M of the selected rows
        .Copy Destination:=wsDest.Cells(LastRow + 1, "A")
        .EntireRow.Delete
    End With

Answer 2

У меня есть макрос, который копирует строку за строкой выбранного диапазона и вставляет его в следующий.Может быть, это поможет.

Кроме того, если вы знаете количество строк, с которыми вы работаете, вы всегда можете выполнить

    Range(Ax:Lx).Select

Если нет, это может помочь:

    Dim i As Integer
    i = 2 //1 if first row isn't headers. 
    Do While sht1.Range("A" & i).Value <> Empty
    sht1.Range("A" & i & "L" & i).Select
    Selection.Copy
    sht2.Range("A" & lastrow +1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    i = i + 1
    Loop

Дайте мне знать, если это помогает или нуждается в корректировке.