Блог

Этот макрос предназначен для перемещения записей с основного листа на другие листы на основе критериев из столбца F.

Ошибка несоответствия типа возникает в случае «Завершения», когда выбирается ячейка «B2».

Я попробовал несколько разных вариантов, но каждый заканчивался разной ошибкой.

 Public Sub moveToSheet()

Sheets("Master").Select
' Find the last row of data
FinalRow = Range("E65000").End(xlUp).Row
'Loop through each row
For x = 2 To FinalRow
    ' Decide where to copy based on column F
    ThisValue = Range("F" amp; x).Value

    Select Case True

    Case ThisValue = "Hiring "
        Sheets("Master").Cells(x, 2).EntireRow.Copy
        Sheets("Hiring").Select
        Sheets("Hiring").Range("B2:W2500").Clear
        Sheets("Hiring").Cells("B2").Select
        ActiveSheet.Paste
        Sheets("Master").Select
    Case ThisValue = "Re-Hiring "
        Sheets("Master").Cells(x, 2).EntireRow.Copy
        Sheets("Hiring").Select
        Sheets("Hiring").Range("B2:W2500").Clear
        Sheets("Hiring").Cells("B2").Select
        ActiveSheet.Paste
    Case ThisValue = "Termination "
        Sheets("Master").Cells(x, 2).EntireRow.Copy
        Sheets("Terminations").Select
        Sheets("Terminations").Range("B2:W2500").Clear
        Sheets("Terminations").Cells("B2").Select
        ActiveSheet.Paste
    Case ThisValue = "Transfer "
        Sheets("Master").Cells(x, 2).EntireRow.Copy
        Sheets("Transfers").Select
        Sheets("Transfers").Range("B2:W2500").Clear
        Sheets("Transfers").Cells("B2").Select
        ActiveSheet.Paste
    Case ThisValue = "Name Change "
        Sheets("Master").Cells(x, 2).EntireRow.Copy
        Sheets("Name Changes").Select
        Sheets("Name Changes").Range("B2:W2500").Clear
        Sheets("Name Changes").Cells("B2").Select
        ActiveSheet.Paste
    Case ThisValue = "Address Change "
        Sheets("Master").Cells(x, 2).EntireRow.Copy
        Sheets("Address Changes").Select
        Sheets("Address Changes").Range("B2:W2500").Clear
        Sheets("Address Changes").Cells("B2").Select
        ActiveSheet.Paste
    Case Else
        Sheets("Master").Cells(x, 2).EntireRow.Copy
        Sheets("New Process").Select
        Sheets("New Process").Range("B2:W2500").Clear
        Sheets("New Process").Cells("B2").Select
        ActiveSheet.Paste
    End Select

Next x

End Sub
  

Есть пара проблем, во-первых, вам нужно использовать синтаксис Range("B2").Select для выбора ячейки. НО, поскольку вы выбрали всю строку из основного листа, вы не можете скопировать всю строку в B2, потому что диапазоны разного размера, поэтому вам нужно выбрать первую ячейку (A2) вместо этого.

Итак, вся инструкция case должна выглядеть следующим образом:

  Case ThisValue = "Termination "
        Sheets("Master").Cells(x, 2).EntireRow.Copy
        Sheets("Terminations").Activate
        Range("A2").Select
        ActiveSheet.Paste
  

Существует ряд проблем

1. В этом нет необходимости Select , используйте переменные вместо
2. Отключите все ваши переменные — помощь в отладке и обучении
3. Некоторые общие рекомендации помогут

Вот (частично) переработанная версия вашего кода

 Public Sub moveToSheet()
    Dim wb As Workbook
    Dim shMaster As Worksheet, shHiring As Worksheet
    Dim rngMaster As Range
    Dim x As Long
    Dim rw As Range

    Set wb = ActiveWorkbook
    Set shMaster = wb.Worksheets("Master")
    Set shHiring = wb.Worksheets("Hiring")
    ' etc

    ' Find the data
    x = shMaster.UsedRange.Count  ' trick to reset used range
    Set rngMaster = shMaster.UsedRange
    'Loop through each row  NOTE looping thru cells is SLOW.  There are faster ways
    For Each rw In rngMaster.Rows
        ' Decide where to copy based on column F
        Select Case Trim$(rw.Cells(1, 6).Value)  ' Is there really a space on the end?
            Case "Hiring"
                shHiring.[B2:W2500].Clear
                rw.Copy shHiring.[B2]
'            Case ' etc
        End Select
    Next rw
  

Это то, что я в основном использую, чтобы делать именно то, о чем вы говорите. У меня есть «основной» лист, состоящий из нескольких тысяч строк и пары сотен столбцов. Эта базовая версия выполняет поиск только в столбце Y, а затем копирует строки. Однако, поскольку другие люди используют это, у меня есть несколько листов шаблонов, которые я держу в секрете, чтобы вы могли отредактировать их, если не хотите использовать шаблоны. Я также могу добавить дополнительные переменные поиска, если это необходимо, и просто добавить еще пару строк достаточно просто. Итак, если вы хотите скопировать строки, соответствующие двум переменным, то вам следует определить другую переменную Dim d as Range и Set d = shtMaster.Range("A1") или любой столбец, который вы хотите, для поиска по второй переменной. Затем в строке If измените ее на If c.Value = "XXX" and d.Value = "YYY" Then . Наконец, убедитесь, что вы добавили смещение для новой переменной с помощью c.offset (чтобы внизу была строка Set d = d.Offset(1,0) с другой). Это действительно оказалось довольно гибким для меня.

 Sub CreateDeptReport(Extras As String)

    Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet
    Dim LCopyToRow As Long
    Dim LCopyToCol As Long
    Dim arrColsToCopy
    Dim c As Range, x As Integer

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    On Error GoTo Err_Execute

    arrColsToCopy = Array(1, 3, 4, 8, 25, 25, 21, 16, 17, 15, 31, 7) 'which columns to copy ?

    Set shtMaster = ThisWorkbook.Sheets("MasterSheet")
    Set c = shtMaster.Range("Y5")  'Start search in Column Y, Row 5

    LCopyToRow = 10 'Start copying data to row 10 in Destination Sheet

    While Len(c.Value) > 0
        'If value in column Y equals defined value, copy to destination sheet
        If c.Value = “XXX” Then

            'only create the new sheet if any records are found
            If shtRpt Is Nothing Then
                'delete any existing sheet
                On Error Resume Next
                ThisWorkbook.Sheets("Destination").Delete
                On Error GoTo 0
                ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
                ThisWorkbook.Sheets("Template").Copy After:=shtMaster
                Set shtRpt = ThisWorkbook.Sheets(shtMaster.Index   1)
                shtRpt.Name = "Destination" 'rename new sheet to Destination
    ‘Optional Information; can edit the next three lines out - 
                Range("F1").Value = "Department Name"
                Range("F2").Value = "Department Head Name"
                Range("B3").Value = Date
                ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
            End If

            LCopyToCol = 1

            shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert shift:=xlDown

            For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)

                shtRpt.Cells(LCopyToRow, LCopyToCol).Value = _
                            c.EntireRow.Cells(arrColsToCopy(x)).Value

                LCopyToCol = LCopyToCol   1

            Next x            
            LCopyToRow = LCopyToRow   1 'next row
        End If
        Set c = c.Offset(1, 0)
    Wend

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    Range("A9").Select 'Position on cell A9
    MsgBox "All matching data has been copied."
    Exit Sub

Err_Execute:
        MsgBox "An error occurred."
End Sub
  

Кроме того, при желании вы могли бы удалить строки обновления экрана. Как бы глупо это ни звучало, некоторым людям действительно нравится видеть, как Excel работает над этим. При отключенном обновлении экрана вы не сможете увидеть лист назначения, пока копирование не будет завершено, но при обновлении экран мерцает как сумасшедший из-за того, что он пытается обновить при копировании каждой строки. Некоторые пожилые люди в моем офисе думают, что Excel сломан, когда они не могут видеть, что это происходит, поэтому я продолжаю обновлять экран большую часть времени. лол
Кроме того, мне нравится иметь шаблоны, потому что во всех моих отчетах есть довольно много формул, которые необходимо вычислить после разбивки информации, поэтому я могу сохранить все формулы там, где я хочу, с помощью шаблона. Затем все, что мне нужно сделать, это запустить макрос для извлечения из основного листа, и отчет готов к работе без какой-либо дальнейшей работы.