Excel VBA Копирование и вставка в несколько листов в зависимости от условий

Question

Мне нужен код Excel VBA, который поможет мне автоматизировать следующее:

Мне нужно иметь возможность копировать и вставлять строки из «главной» рабочей таблицы в несколько вновь созданных рабочих таблиц на основе данных, найденных в столбце «K», с заголовком «Skill». Если столбец K имеет следующие значения: «DEL-LPT-PRECISN», «DEL-LPT-XPS», «DEL-LT-ALIENWARE», «DEL-PC-AIO-OPTI», «DEL-PC-AIO-XPS». "," DEL-PC-PRECISION "скопировать всю строку на вновь созданную рабочую таблицу." Трудно ". Если в столбце" K "есть что-то еще, переместите его на вновь созданную рабочую таблицу" Easy "

Заголовки столбцов должны быть одинаковыми от мастера до двух вновь созданных wks "easy" и "hard"

Основная рабочая таблица меняется ежедневно и может содержать от 200 до 500 строк данных.

Заранее спасибо за помощь!

Answer 1

Вы можете легко сделать это, используя предварительные фильтры. Или вы можете написать макрос для фильтрации по каждому критерию и соответственно скопировать / вставить.

Или вы можете использовать этот менее эффективный код.

Допущения:

1. У вас уже есть 3 листа с именами «Мастер», «Твердый», «Легкий» в вашей рабочей тетради
2. Каждый лист имеет заголовки
3. Все заголовки идентичны

---

Option Explicit

Sub MoveData()

Dim Master As Worksheet: Set Master = ThisWorkbook.Sheets("Master")
Dim Hard As Worksheet: Set Hard = ThisWorkbook.Sheets("Hard")
Dim Easy As Worksheet: Set Easy = ThisWorkbook.Sheets("Easy")

Dim String1, String2, String3, String4, String5, String6 As String
String1 = "DEL-LPT-PRECISN"
String2 = "DEL-LPT-XPS"
String3 = "DEL-LT-ALIENWARE"
String4 = "DEL-PC-AIO-OPTI"
String5 = "DEL-PC-AIO-XPS"
String6 = "DEL-PC-PRECISION"

Dim MyCell As Range

Application.ScreenUpdating = False
    For Each MyCell In Master.Range("K2:K" & Master.Range("K" & Master.Rows.Count).End(xlUp).Row)
        If MyCell.Text = String1 Or MyCell.Text = String2 Or MyCell.Text = String3 Or MyCell.Text = String4 Or MyCell.Text = String5 Or MyCell.Text = String6 Then
            Cell.EntireRow.Copy Hard.Range("A" & Hard.Range("A" & Hard.Rows.Count).End(xlUp).Offset(1).Row)
        Else
            Cell.EntireRow.Copy Easy.Range("A" & Easy.Range("A" & Easy.Rows.Count).End(xlUp).Offset(1).Row)
        End If
    Next MyCell
Application.ScreenUpdating = True

End Sub