Совет. Другие языки - Google-Translated. Вы можете посетить English версия этой ссылки.
Войти
x
or
x
x
Регистрация
x

or

Как переместить всю строку на другой лист на основе значения ячейки в Excel?

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

Переместить всю строку на другой лист на основе значения ячейки с кодом VBA

Переместить всю строку на другой лист на основе значения ячейки с помощью Kutools for Excel


Легко выбирать целые строки на основе значения ячейки в столбце certian:

Выберите конкретные ячейки полезности Kutools for Excel может помочь вам быстро выбрать целые строки на основе значения ячейки в столбце certian в Excel, как показано ниже. После выбора всех строк на основе значения ячейки вы можете вручную переместить или скопировать их в новое место по мере необходимости в Excel.

Kutools for Excel: с более чем 200 удобными надстройками Excel, бесплатно попробовать без ограничений в 60-дни. Скачайте бесплатную пробную версию прямо сейчас!

Вкладка «Office» Включите редактирование и просмотр с вкладками в Office и упростите свою работу ...
Kutools для Excel переносит расширенные функции 300 в Excel и мгновенно повышает производительность
  • Super Formula Bar (легко редактировать несколько строк текста и формул); Чтение макета (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон ...
  • Объединить ячейки / строки / столбцы и хранение данных; Содержание сплит-клеток; Объединить дублирующиеся строки и сумму / среднее ... Предотвратить повторяющиеся клетки; Сравнить диапазоны ...
  • Выберите Дублировать или Уникальные строки; Выберите пустые строки (все ячейки пусты); Супер найти и нечеткая находка во многих книгах; Случайный выбор ...
  • Точное копирование нескольких ячеек без изменения ссылки на формулу; Автоматическое создание ссылок на несколько листов; Вставьте маркеры, флажки и многое другое ...
  • Любить и быстро вставлять формулы, диапазоны, графики и рисунки; Шифровать ячейки с помощью пароля; Создать список рассылки и отправлять электронные письма ...
  • Извлечь текст, Добавить текст, Удалить по позиции, Удалить пробел; Создание и печать промежуточных итогов подкачки; Преобразование содержимого ячеек и комментариев ...
  • Суперфильтр (сохранение и применение схем фильтрации к другим листам); Расширенный Сортировать по месяцу / неделе / ​​дню, частоте и многому другому; Специальный фильтр жирным шрифтом, курсив ...
  • Объединить рабочие тетради и рабочие листы; Объединение таблиц на основе ключевых столбцов; Разбить данные на несколько листов; Пакетное конвертирование xls, xlsx и PDF ...
  • Работает с Office 2007-2019 и 365 и поддерживает все языки. Это легко развернуть в вашей компании. Полнофункциональная 60-дневная бесплатная пробная версия.

Переместить всю строку на другой лист на основе значения ячейки с кодом VBA


Как показано ниже, вам нужно переместить всю строку с Sheet1 на Sheet2, если в столбце C. существует конкретное слово «Готово». Вы можете попробовать следующий код VBA.

1. Нажмите другой+ F11 , чтобы открыть Microsoft Visual Basic для приложений окна.

2. В окне Microsoft Visual Basic для приложений щелкните Вставить > модуль, Затем скопируйте и вставьте следующий код VBA в окно.

Код VBA 1: переместить всю строку на другой лист на основе значения ячейки

Sub Cheezy()
'Updated by Kutools for Excel 2017/8/28
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Done" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "Done" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Внимание: В коде, Sheet1 это рабочий лист содержит строку, которую вы хотите переместить. А также Sheet2 это рабочий лист адресата, где вы найдете строку. «C: C"Это столбец содержит определенное значение, а слово"Готово"- это определенное значение, на котором вы будете перемещать строку на основе. Пожалуйста, измените их в соответствии с вашими потребностями.

3. нажмите F5 ключ для запуска кода, то строка, соответствующая критериям в Sheet1, будет немедленно перенесена в Sheet2.

Внимание: Вышеуказанный код VBA удалит строки из исходных данных после перехода к указанному листу. Если вы хотите только скопировать строки на основе значения ячейки, а не удалять их. Пожалуйста, примените следующий код VBA 2.

Код VBA 2: скопировать всю строку на другой лист на основе значения ячейки

Sub MoveRowBasedOnCellValue()
'Updated by Extendoffice 2017/11/10
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Done" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Переместить всю строку на другой лист на основе значения ячейки с помощью Kutools for Excel

Если вы новичок в коде VBA. Здесь я представляю Выберите конкретные ячейки полезности Kutools for Excel, С помощью этой утилиты вы можете легко выбрать все строки на основе определенного значения ячейки или разных значений ячейки на листе и скопировать выбранные строки на рабочий лист адресата по мере необходимости. Пожалуйста, сделайте следующее.

Kutools for Excel : с более чем 300 удобными надстройками Excel, бесплатно попробовать без ограничений в 60-дни.

1. Выберите в списке столбцов значение ячейки, на которое вы будете перемещать строки, затем нажмите Kutools > Выбрать > Выберите конкретные ячейки, Смотрите скриншот:

2. В открытии Выберите конкретные ячейки диалоговое окно, выберите Весь ряд , который относится к Тип выбора раздел, выберите Равно , который относится к Конкретный тип , введите значение ячейки в текстовое поле, а затем нажмите кнопку OK Кнопка.

Другой Выберите конкретные ячейки появится диалоговое окно, чтобы отобразить количество выбранных строк, а между тем все строки, содержащие указанное значение в выбранном столбце, были выбраны. Смотрите скриншот:

3. нажмите Ctrl + C чтобы скопировать выбранные строки, а затем вставить их в нужную таблицу назначения.

Внимание: Если вы хотите переместить строки на другой рабочий лист на основе двух разных значений ячейки. Например, перемещайте строки на основе значений ячеек «Готово» или «Обработка», вы можете включить Or условие в Выберите конкретные ячейки диалоговое окно, как показано ниже:

Наконечник.Если вы хотите получить бесплатную пробную версию этой утилиты, перейдите по ссылке бесплатно скачать программное обеспечение сначала, а затем перейдите, чтобы применить операцию согласно вышеуказанным шагам.


Статьи по теме:


  • Супер Формула Бар (легко редактировать несколько строк текста и формул); Макет чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон...
  • Объединить ячейки / строки / столбцы и хранение данных; Содержание сплит-клеток; Объедините дублирующиеся строки и сумму / среднее... предотвратить повторяющиеся клетки; Сравнить диапазоны...
  • Выберите Дубликат или Уникальный Ряды; Выберите пустые строки (все ячейки пусты); Супер найти и нечеткая находка во многих рабочих тетрадях; Случайный выбор ...
  • Точная копия Несколько ячеек без изменения формулы ссылки; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое ...
  • Любимые и быстро вставляемые формулы, Диапазоны, графики и рисунки; Шифрование ячеек с паролем; Создать список рассылки и отправлять электронные письма ...
  • Извлечение текстаДобавить текст, Удалить по позиции, Удалить пространство; Создание и печать промежуточных итогов подкачки; Преобразование содержимого ячеек и комментариев...
  • Суперфильтр (сохранить и применить схемы фильтров к другим листам); Расширенный поиск по месяцам / неделям / дням, частоте и более; Специальный фильтр жирным шрифтом, курсивом ...
  • Объединить рабочие тетради и рабочие листы; Объединение таблиц на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF...
  • Работает с Office 2007-2019 и 365 и поддерживает все языки. Это легко развернуть в вашей компании. Полнофункциональная 60-дневная бесплатная пробная версия.
вкладка kte 201905
  • Включить редактирование и чтение с вкладками в Word, Excel, PowerPoint, Издатель, Доступ, Visio и Проект.
  • Открывайте и создавайте несколько документов в новых вкладках одного и того же окна, а не в новых окнах.
  • Увеличивает вашу производительность на 50% и уменьшает сотни щелчков мышью для вас каждый день!
нижняя часть офиса
Say something here...
symbols left.
You are guest ( Sign Up? )
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    Tyler · 5 days ago
    Hello - I love this code! Thanks so much. One thing I was wondering is how you could manipulate the code to pull in more than one piece of date. For ex. if the selected column contained "Done" and "Pending". I've tried a few different codes and couldn't get it.

    Any help would be greatly appreciated!

    Thanks again! :)
  • To post as a guest, your comment is unpublished.
    Rose · 8 days ago
    Hi, Thank you for your post! Currently, I have adapted your code to shift a row from one sheet to the other. Right now, I'm writing another module so that I can shift the row back to the original row position (in case where the cell value entry was entered wrongly). Would it be possible to allocate it back specifically to the row where it shifted from?
  • To post as a guest, your comment is unpublished.
    Natasha Leon · 16 days ago
    Hi

    I tried to read all of the comments but was unable to find the solution to my issue.
    I have 5 transaction codes (IPL, ISL, CAPO, IIC, IMO) in cell DC
    If cell DC = "ISL" or "IIC" or "IMO" then copy that row but only columns DE:FN to a new sheet in a new workbook
    If cell DC = "IPL" then copy that row but only columns DE:FN to a new sheet in another new workbook
    If cell DC = "CAPO" then copy that row but only columns DE:FN to a new sheet in another new workbook

    I want each new workbook sorted by the 14th column in the extracted range & saved in a specified location with the macro ending after the newly created workbooks have been closed.
  • To post as a guest, your comment is unpublished.
    Isaiah · 24 days ago
    Is there a way to prevent data from being duplicated when copied? I want to use this as sort of a long term log and the sheet I am entering data into is the weekly variant. I am copying my entries to a longterm yearly version. Currently this script produces duplicates each time an entry is made. I need to prevent these duplicates.
  • To post as a guest, your comment is unpublished.
    Stephen · 25 days ago
    Is there a way I could insert the row into the top row of a table on the second page?
  • To post as a guest, your comment is unpublished.
    Aleksandar · 1 months ago
    Hi, how can I copy entire line based on values in row K and must be more then 0, I tried but...
    Thanks crystal :)
  • To post as a guest, your comment is unpublished.
    Harry · 1 months ago
    Hi, This thread has been really helpful. I was just wondering how I would modify the below code to only copy cells A & B for each "Done" row instead or the entire row.

    e.g. for row 6, C6 = "Done". How would i copy only cells A6 & B6 across to the next sheet instead of the entire row



    VBA code 2: Copy entire row to another sheet based on cell value

    Sub MoveRowBasedOnCellValue()
    'Updated by Extendoffice 2017/11/10
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
    If CStr(xRg(K).Value) = "Done" Then
    xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
    J = J + 1
    End If
    Next
    Application.ScreenUpdating = True
    End Sub


    Thank you in advance
  • To post as a guest, your comment is unpublished.
    Jackson · 1 months ago
    I am using your code, however I encounter an error with line 8 (below) when I run the macro

    I = Worksheets("Sheet1").UsedRange.Rows.Count

    I'm at a loss as to why this may be occurring, would this macro be affected by there being several drop down lists in the row? or by applied conditional formatting?
    • To post as a guest, your comment is unpublished.
      crystal · 1 months ago
      Hi Jackson,
      The macro doesn't be affected by drop-down lists as well as conditional formatting.
      Have you change the sheet name in this line to your actually used sheet name?
  • To post as a guest, your comment is unpublished.
    Hassan Arshad · 1 months ago
    Hi, could you please help me out how can I use this with activex control button e.g. when I press the button then data move to sheet2? Thank you so much
    • To post as a guest, your comment is unpublished.
      crystal · 1 months ago
      Hi Hassan Arshad,
      Right click the activex control button and select View Code from the context menu, then copy the below code between the Private Sub and the End Sub lines.

      Dim xRg As Range
      Dim xCell As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      I = Worksheets("Sheet1").UsedRange.Rows.Count
      J = Worksheets("Sheet2").UsedRange.Rows.Count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
      End If
      Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      If CStr(xRg(K).Value) = "Done" Then
      xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
      xRg(K).EntireRow.Delete
      If CStr(xRg(K).Value) = "Done" Then
      K = K - 1
      End If
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
  • To post as a guest, your comment is unpublished.
    Bradley · 2 months ago
    How do I make the VBA code run automatically? When the cell I am targeting changes to the value, it is not deleting and moving. I have to open the dialog and run it.
    • To post as a guest, your comment is unpublished.
      Laurie Black · 25 days ago
      Make sure to add Developer tab first

      On the Developer tab, in the Code group, click Macros.
      In the Macro name box, click the macro you want to run and press the Run button.

      You will also have the choice to add a shortkey from here
  • To post as a guest, your comment is unpublished.
    Andrew · 4 months ago
    This is a HUGE help, thank you! Is there a way to move rows if values are less than a given value?
  • To post as a guest, your comment is unpublished.
    Anne · 6 months ago
    Hello, thank you so much for this post. Instead of only "Done" I have several words to find, it can be around 100. I have them all in Column A of Sheet 2. I need to find those words from Sheet 1 and paste the entire row(s) in sheet 3, if the words match. How can I do that? I would really appreciate your help.
  • To post as a guest, your comment is unpublished.
    Anju · 6 months ago
    Hi, I have a sheet where are liscence renewal details are present, when the due date is nearing (before 2 months) those liscence details need to sent as an email to a single recipient. I have used today formula and calculated the days remaining from the due date. So I am using that cell- if the value is above 60, it must copy the entire cell and put it into another workbook. It has to repeat this until it reaches the end. could you help me writing a code on this ?
  • To post as a guest, your comment is unpublished.
    Anne · 6 months ago
    Hello, thank you so much for this code. How To Move Entire Row To Another Sheet Based On a column? Let's say in sheet 2, I have Case IDs in column A. And I need to find anything associated with those Case IDs in Sheet 1 and paste it in Sheet 3. Can you please help me do that?
    • To post as a guest, your comment is unpublished.
      crystal · 5 months ago
      Hi Anne,
      Sorry can't help you with that. Thank you for your comment.
  • To post as a guest, your comment is unpublished.
    TJ · 6 months ago
    Thanks, this helped me alot. I am not an Excel expert! I used the the module in VBA you created to transfer rows from Sheet 1 to Sheet 2. My project is that I'm moving objects to designated locations that were set up in a certain order in another column located in Sheet 1. When I run the module, I lose the location because the rows shift up in Sheet 1 after the transfer. I have to insert a row and type in the designated location again. Can it be set up so that I can at least keep the blank row and just type in the location needed?
  • To post as a guest, your comment is unpublished.
    SB · 7 months ago
    Thank you! If it is not too much trouble could you please post how to have the destination data overwrite vs. append to the last line? Specifically to overwrite data starting at A2. Thank you!
    • To post as a guest, your comment is unpublished.
      crystal · 1 months ago
      Good Day,
      For moving data and overwrite data starting at A2 in the destination worksheet, please apply the below code.

      Sub MoveRowOverwrite()
      Dim xRg As Range
      Dim xCell As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      I = Worksheets("Sheet1").UsedRange.Rows.Count
      J = 1
      Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      If CStr(xRg(K).Value) = "Done" Then
      xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
      xRg(K).EntireRow.Delete
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
      End Sub
  • To post as a guest, your comment is unpublished.
    Charlene · 7 months ago
    I have a drop down list to code which person transfers to which sheet. But I can only get one person to transfer with your code. Help? :)
    • To post as a guest, your comment is unpublished.
      crystal · 5 months ago
      Hi Charlene,
      The following VBA code can help you solve the problem. Please change the "PERSON1" and "PERSON2" to the person as you need. In this case, the row of PERSON1 will be moved to Sheet2, and the row of PERSON2 will be moved to Sheet3.

      Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      Dim xRg As Range
      Dim xCell As Range
      Dim xRRg1 As Range
      Dim xRRg2 As Range
      Dim xDWS As Worksheet
      Dim xLWS As Worksheet
      Dim xEWS As Worksheet
      Dim xDR, xLR, xER As Long
      Dim xDC As Long
      Dim K As Long
      Dim xC1 As Long
      Dim xFNum As Long
      Set xDWS = Worksheets("Sheet1")
      Set xLWS = Worksheets("Sheet2") 'LIVE
      Set xEWS = Worksheets("Sheet3") 'ENDED
      xDR = xDWS.UsedRange.Rows.Count
      xLR = xLWS.UsedRange.Rows.Count
      xER = xEWS.UsedRange.Rows.Count
      xDC = xDWS.UsedRange.Columns.Count
      If xLR = 1 Then
      If Application.WorksheetFunction.CountA(xLWS.UsedRange) = 0 Then xLR = 0
      End If
      If xER = 1 Then
      If Application.WorksheetFunction.CountA(xEWS.UsedRange) = 0 Then xER = 0
      End If
      Set xRg = xDWS.Range("C1:C" & xDR)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      If CStr(xRg(K).Value) = "PERSON1" Then
      Set xRRg1 = xRg(K).EntireRow
      Set xRRg2 = xLWS.Range("A" & xLR + 1).EntireRow
      For xFNum = 1 To xDC
      xRRg2.Value = xRRg1.Value
      Next xFNum
      xRg(K).EntireRow.Delete
      xLR = xLR + 1
      ElseIf CStr(xRg(K).Value) = "PERSON2" Then
      Set xRRg1 = xRg(K).EntireRow
      Set xRRg2 = xEWS.Range("A" & xER + 1).EntireRow
      For xFNum = 1 To xDC
      xRRg2.Value = xRRg1.Value
      Next xFNum
      xRg(K).EntireRow.Delete
      xER = xER + 1
      End If
      Next K
      Application.ScreenUpdating = True
      End Sub
  • To post as a guest, your comment is unpublished.
    CAROL · 8 months ago
    I am using the formula to move rows to a second tab and delete the row from the first tab...it is deleting the row in the first tab, but not moving the row to the second. I'm wondering if it is because I have not give the correct qualifier to "A" in row 18 of the formula?? What is the "A" for?
    • To post as a guest, your comment is unpublished.
      crystal · 8 months ago
      Hi Carol,
      The "A" in row 18 means that the qualified row will be moved to the first column in the given sheet.
  • To post as a guest, your comment is unpublished.
    Carol · 8 months ago
    I'm trying to use the formula to move rows to another tab while deleting the row in the original tab. The formula deletes from the original tab, but does not move the information. I'm wondering if it is because I have not given a qualifier for the "A" in line 18 of the module. What is that for?
  • To post as a guest, your comment is unpublished.
    tom · 8 months ago
    This is AMAZING! how would I modify to capture 2 criteria?? Ex: Cell in main workbook column C = 'Done'...and column A shows either 'Tom', 'Dick', or 'Harry'. I have a tabs in the workbook for Tom, Dick, and Harry.... so if row had Done and Tom, it would be appended to the end of the spreadsheet on the Tom tab.
  • To post as a guest, your comment is unpublished.
    pawJ · 9 months ago
    works more or less. It copy's the right ine, but does not copy it to the first line in the given sheet. It leaves a number of empty lines at first
  • To post as a guest, your comment is unpublished.
    Robert Mayer · 9 months ago
    Hello Crystal,


    I am using VBA 1 and it is working great. I added the automatic code to my sheet to automate the process and when i put in the trigger word it deletes that line and all of the lines below it, wiping out my entire table.


    Do you have any suggestions?


    Thank you,
    Robert
    • To post as a guest, your comment is unpublished.
      crystal · 8 months ago
      Hi Robert Mayer,
      Your automatic code should be as follows.

      Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      Dim xRg As Range
      Dim xCell As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      I = Worksheets("Sheet1").UsedRange.Rows.Count
      J = Worksheets("Sheet2").UsedRange.Rows.Count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
      End If
      Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      If CStr(xRg(K).Value) = "Done" Then
      xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
      xRg(K).EntireRow.Delete
      If CStr(xRg(K).Value) = "Done" Then
      K = K - 1
      End If
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
      End Sub
      Please have a try. If problem still exists, please let me know and tell me your Excel version.
      Thanks you for your comment.
  • To post as a guest, your comment is unpublished.
    Scott · 9 months ago
    How can move the selected row and paste it as a "Value". My selection has formulas, so when it is moved I get a lot of ref errors since it's still tied to the original formula.
    • To post as a guest, your comment is unpublished.
      crystal · 9 months ago
      Hi Scott,
      The below VBA code can solve the problem, please have a try. Thank you for your comment.

      Sub Cheezy01()
      Dim xRg As Range
      Dim xCell As Range
      Dim xRRg1 As Range
      Dim xRRg2 As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      Dim xC1 As Long
      Dim xFNum As Long
      Dim xDShName As String
      Dim xRShName As String
      xDShName = "Sheet1"
      xRShName = "Sheet2"
      I = Worksheets(xDShName).UsedRange.Rows.count
      J = Worksheets(xRShName).UsedRange.Rows.count
      xC1 = Worksheets(xDShName).UsedRange.Columns.count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets(xRShName).UsedRange) = 0 Then J = 0
      End If
      Set xRg = Worksheets(xDShName).Range("C1:C" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.count
      If CStr(xRg(K).Value) = "Done" Then
      Set xRRg1 = xRg(K).EntireRow
      Set xRRg2 = Worksheets(xRShName).Range("A" & J + 1).EntireRow

      xRRg2.Value = xRRg1.Value

      xRg(K).EntireRow.Delete
      If CStr(xRg(K).Value) = "Done" Then
      K = K - 1
      End If
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
      End Sub
  • To post as a guest, your comment is unpublished.
    liam · 10 months ago
    Hi, This works great and is very helpful but can you explain how I would do the following?

    I have column "M" which has "LIVE" & "ENDED", I have used your code to work so that "LIVE" goes to "Sheet2" but how do I add more code so that "ENDED" is copied to "Sheet3"?

    Thank you
    • To post as a guest, your comment is unpublished.
      Anne · 6 months ago
      Good question, what about if I have several of those "LIVE" "ENDED" "DONE" "GONE" "SUNDAY" etc... It can be up to 89, they are listed in a column.
    • To post as a guest, your comment is unpublished.
      crystal · 9 months ago
      Hi Liam,
      Please try the following VBA code. Hope it can help and thank you for your comment.

      Sub Cheezy()
      Dim xRg As Range
      Dim xCell As Range
      Dim xRRg1 As Range
      Dim xRRg2 As Range
      Dim xDWS As Worksheet
      Dim xLWS As Worksheet
      Dim xEWS As Worksheet
      Dim xDR, xLR, xER As Long
      Dim xDC As Long
      Dim K As Long
      Dim xC1 As Long
      Dim xFNum As Long
      Set xDWS = Worksheets("Sheet1")
      Set xLWS = Worksheets("Sheet2") 'LIVE
      Set xEWS = Worksheets("Sheet3") 'ENDED
      xDR = xDWS.UsedRange.Rows.count
      xLR = xLWS.UsedRange.Rows.count
      xER = xEWS.UsedRange.Rows.count
      xDC = xDWS.UsedRange.Columns.count
      If xLR = 1 Then
      If Application.WorksheetFunction.CountA(xLWS.UsedRange) = 0 Then xLR = 0
      End If
      If xER = 1 Then
      If Application.WorksheetFunction.CountA(xEWS.UsedRange) = 0 Then xER = 0
      End If
      Set xRg = xDWS.Range("C1:C" & xDR)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.count
      If CStr(xRg(K).Value) = "LIVE" Then
      Set xRRg1 = xRg(K).EntireRow
      Set xRRg2 = xLWS.Range("A" & xLR + 1).EntireRow
      For xFNum = 1 To xDC
      xRRg2.Value = xRRg1.Value
      Next xFNum
      xRg(K).EntireRow.Delete
      xLR = xLR + 1
      ElseIf CStr(xRg(K).Value) = "ENDED" Then
      Set xRRg1 = xRg(K).EntireRow
      Set xRRg2 = xEWS.Range("A" & xER + 1).EntireRow
      For xFNum = 1 To xDC
      xRRg2.Value = xRRg1.Value
      Next xFNum
      xRg(K).EntireRow.Delete
      xER = xER + 1
      End If
      Next K
      Application.ScreenUpdating = True
      End Sub
  • To post as a guest, your comment is unpublished.
    R3 · 11 months ago
    Hi, I get a syntax error on the line:

    Set xRg = Worksheets("Maternity Sub-Committee ACCC").Range("B:B" & I)

    Can you please help me? Thanks
    • To post as a guest, your comment is unpublished.
      Guest · 11 months ago
      For your range, it needs to be "B1:B". That will make it work!
  • To post as a guest, your comment is unpublished.
    AV · 1 years ago
    I used this code previously without problems, but now I can't get it to work quite right (I have no VB coding experience, so probably a silly mistake). Everything works except the row I want doesn't get copied to the final destination of Sheet2 - nothing appears there. Original row deleted just fine from Sheet1. I do have a header row in Sheet2 - could that be a problem?
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Good day,
      The problem you mentioned does not appear in my case. Do you mind uploading your workbook for me to check?
      Thanks for your comment.
  • To post as a guest, your comment is unpublished.
    D company · 1 years ago
    Not working for me !!!!! please help!!!!



    I am getting syntax error on first line Sub Cheezy()
    What changes I need to do to fix this.
    I made changes as mentioned in description.
  • To post as a guest, your comment is unpublished.
    Ramesh · 1 years ago
    It is not working for me please help!!!!!!



    its giving me an syntax error at first line Sub Cheezy().


    I copped code as it is and changed values mentioned in description.
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Hi Ramesh,
      May I know your Office verson? I need the feedback to check for the error. Thanks for your comment.
  • To post as a guest, your comment is unpublished.
    Ryan · 1 years ago
    I'm trying to move cells with a VLOOKUP function and when I use the code below, it pastes the formula, but it moves the cell values down as it pastes the formula down the rows. For example... the row that I'm copying is looking up $A1:$B27. When it pastes on the next sheet using the Macro it pastes $A2:$B29 then $A3:$B30 and so on and so forth. Is there a fix for this either in my VBA code or in my VLOOKUP formula?
  • To post as a guest, your comment is unpublished.
    gowtham · 1 years ago
    Hi,

    If i add the data in sheet1 it is not moving automatically,how to copy the data to another sheets
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Hi gowtham,
      If you want to automatically move the row after entering the data, please try the below VBA code.

      Private Sub Worksheet_Change(ByVal Target As Range)
      Dim xRg As Range
      Dim xCell As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      On Error Resume Next
      Application.ScreenUpdating = False
      If Target.Count = 1 And Intersect(Target, Columns(3)) Then
      I = ActiveSheet.UsedRange.Rows.Count
      J = Worksheets("Sheet2").UsedRange.Rows.Count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
      End If
      If Target.Value = "Done" Then
      Target.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
      Target.EntireRow.Delete
      End If
      End If
      Application.ScreenUpdating = True
      End Sub
      • To post as a guest, your comment is unpublished.
        Steph · 1 years ago
        Do you add this in place of Sub Cheezy()'s VBA, or in addition to? If so, where do you place it? (VBA newbie here)
      • To post as a guest, your comment is unpublished.
        Kim · 1 years ago
        Hello Crystal,

        Good day! I have been following your posts and I really appreciate all the tips and tricks you've been giving to everyone.
        Is it possible to help me please on my current challenge? I have been working on a file where I need to check if the value on the cell is found on a range from another sheet, then move it to another sheet.

        Here's my scenario

        Sheet1, range B2:B100 contains the range of values that serve as masterdata/list

        Sheet2, column C is what should be checked - if value is found on sheet1 range B2:B100

        Sheet3: If Sheet 2 Column C data is found, then entire row is moved to Sheet3.

        I have been using your early reference www.extendoffice.com/documents/excel/372....html?page_comment=1

        but it is only for a single criteria.



        Thank you in advance!
        • To post as a guest, your comment is unpublished.
          crystal · 1 years ago
          Hi Kim,
          The below VBA code can help you solve the problem. Thanks for your comment.

          Sub Cheezy()
          'Updated by Kutools for Excel 2018/8/6

          Dim xRg As Range
          Dim yRg As Range
          Dim I As Long
          Dim K As Long
          Dim J As Long

          I = Worksheets("Sheet1").UsedRange.Rows.Count
          J = Worksheets("Sheet3").UsedRange.Rows.Count
          secRow = Worksheets("Sheet2").UsedRange.Rows.Count
          If J = 1 Then
          If Application.WorksheetFunction.CountA(Worksheets("Sheet3").UsedRange) = 0 Then J = 0
          End If

          Set xRg = Worksheets("Sheet1").Range("B2:B100")
          'Set xRg = Worksheets("Sheet1").Range("A1:C" & I)
          Set yRg = Worksheets("Sheet2").Range("C1:C" & secRow)

          On Error Resume Next
          Application.ScreenUpdating = False
          Dim M As Long
          Dim N As Long

          For N = 1 To xRg.Count
          For M = 1 To yRg.Count
          If CStr(xRg(N).Value) = CStr(yRg(M).Value) Then
          yRg(M).EntireRow.Copy Destination:=Worksheets("Sheet3").Range("A" & J + 1)
          yRg(M).EntireRow.Delete
          If CStr(xRg(N).Value) = CStr(yRg(M).Value) Then
          N = N - 1
          End If
          J = J + 1
          End If
          Next

          Next

          Application.ScreenUpdating = True
          End Sub
          • To post as a guest, your comment is unpublished.
            Kim · 1 years ago
            Hi Crystal, Thank you! This worked for me.

            Going back to the original codes to move rows to another worksheet. It's been working for me for sometime.

            Now I have this issue where, whenever I start to trigger the macro, the cut cells are not moved to the next blank rows.

            E.g. I have A1:Z1 as my headers, the data starts to fill rows A33 onwards.

            Have you encountered this before?


            One thing I did though is that I have copied the macro into different buttons, and tailor fit depending on what sheet I need to paste. Does that impact the original sheet? or any sheets? Thank you.
  • To post as a guest, your comment is unpublished.
    kassidy · 1 years ago
    This vba works perfectly for what I need to do, except I want the values pasted into Sheet 2 in a specific range. So, if sheet 1 data meets my criteria, it needs to populate into a formatted table on sheet 2. This table allows my data to be pasted from C6:H39. Is there anyway to change the code so that the data isn't pasted into the next available row on sheet 2?
  • To post as a guest, your comment is unpublished.
    Veer · 1 years ago
    Hi,
    Thanks for the the code above...its every helpful.
    I wanted one more help...can we have a code which will create a new row (entire row) in sheet 2 as it is doing now but only specific column data is pasted...

    Eg. Sheet 1 has say 7 columns - Client Name, Product, Address,Qty, Amount, Date, Order Status
    In sheet 2 i want only 4 columns- Client Name,Product, Amount, Date

    Now in sheet2 these 4 columns will populate from sheet 1 and rest columns relating to order processing will be entered by user.

    Thank in advance...
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Good day,
      Can't help with this. Thanks for your comment.
  • To post as a guest, your comment is unpublished.
    Jessica · 1 years ago
    The code for copying to a new sheet worked as expected. The issue I'm having is that I need to pull data from 3 sheets into a 4th sheet.

    How can I alter this to include data from "Sheet 1", "Sheet 2", and "Sheet 3" and copy it to "Sheet 4"?
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Hi Jessica,
      Thanks for your comment. Please try the below VBA code to solve your problem.

      Sub CopyRowBasedOnCellValueInWorksheets()
      Dim xWSArray As Variant
      Dim xWs, xDWs As Worksheet
      Dim xRg As Range
      Dim xCell As Range
      Dim xFNum As Integer
      Dim xDStr As String
      Dim I As Long
      Dim J As Long
      Dim K As Long

      WSArray = Array("Sheet1", "Sheet2", "Sheet3")
      xDStr = "Sheet4"
      On Error Resume Next
      Set xDWs = Worksheets(xDStr)
      J = xDWs.UsedRange.Rows.count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(xDWs.UsedRange) = 0 Then J = 0
      End If
      Application.ScreenUpdating = False
      For xFNum = LBound(WSArray) To UBound(WSArray)
      On Error GoTo Error1
      Set xWs = Worksheets(WSArray(xFNum))
      I = xWs.UsedRange.Rows.count
      Set xRg = xWs.Range("C1:C" & I)
      For K = 1 To xRg.count
      If CStr(xRg(K).Value) = "Done" Then
      xRg(K).EntireRow.Copy Destination:=xDWs.Range("A" & J + 1)
      J = J + 1
      End If
      Next
      Error1:
      Next xFNum
      Application.ScreenUpdating = True

      End Sub
  • To post as a guest, your comment is unpublished.
    Andrew · 1 years ago
    I was also trying to figure out how to move items in columns A - E while deleting the whole row, but when it copies to the last row in the second sheet, it only checks for inputs in columns A - E. So if I have a drop-down menu in column F, it still copies to that row.
  • To post as a guest, your comment is unpublished.
    Andrew · 1 years ago
    Hi Crystal,

    I was wondering if there was a way to copy just the text in the row? Not the color or fill.
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Good day,
      If you just want to move the text in the row, please try the following VBA code.

      Sub MoveRowBasedonCellValue()
      Dim xRg As Range
      Dim xCell As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      I = Worksheets("Sheet1").UsedRange.Rows.Count
      J = Worksheets("Sheet2").UsedRange.Rows.Count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
      End If
      Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      If CStr(xRg(K).Value) = "Done" Then
      xRg(K).EntireRow.Copy
      Worksheets("Sheet2").Range("A" & J + 1).PasteSpecial xlPasteValues
      xRg(K).EntireRow.Delete
      If CStr(xRg(K).Value) = "Done" Then
      K = K - 1
      End If
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
      End Sub
      • To post as a guest, your comment is unpublished.
        sam · 10 months ago
        I need to do this too but nothave my original data be deleted???
  • To post as a guest, your comment is unpublished.
    Bre · 1 years ago
    I have used this in my macro for quite a few months now but I just recently ran into an issue and I am trying to figure out how to get it to properly work again. I have it wrote to move anything that says "Paper" in column T to the Paper Tab but in the recent report I got all of the items ended up being labeled "Paper". So when I manually step through it it will move them properly but then it just keeps going. It doesn't even stop looping through. When I just run the macro by itself it is freezing the Excel document and never finishing. When i manually add something random in column T at the end of the spreadsheet the macro runs just fine. Any help without me having to add something random to be added in if all cells contain the same thing??
  • To post as a guest, your comment is unpublished.
    Gwen · 1 years ago
    Do you have any suggestions for how to make the code work so that it moves a row to the new sheet if there are numbers in the target column, but not if the column reads Pending? I can get it to work in a mockup spreadsheet but not the one I need to change. Thanks!
  • To post as a guest, your comment is unpublished.
    Janelle · 1 years ago
    Hi there,

    I think this is what I am looking for, but I have 4 values I need it to split between sheets how would I do that? For instant, if column L contains a "1" it copies columns a:d to sheet 2, if column L contains "2" it copies columns a:d to sheet 3 and so on. Is this possible?
  • To post as a guest, your comment is unpublished.
    chris · 1 years ago
    Hi,

    i need something to copy and delete rows where column L says "closed" and move the row to another tab/sheet called "closed orders". i tried the script above and it didnt work for my sheet but it did work when i did a test sheet with just 3 coumns.
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Dear chris,
      The code works well in my case. Have you replaced C1:C in the code with L1:L to meet your needs?
  • To post as a guest, your comment is unpublished.
    Ben · 1 years ago
    What if I didn't want to copy the entire row, but a limited amount of columns of that row?
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Hi Ben,
      Please try the below VBA code. The code can help you copy cells A - J from current worksheet "Sheet1" to another one "Data", and delete the ENTIRE row from the "Sheet1" once it has been copied over to the "Data" sheet. Hope it can help. Thank you.

      Private Sub Worksheet_Change(ByVal Target As Range)
      Dim xRg As Range
      Dim xCell As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      I = Worksheets("Sheet1").UsedRange.Rows.Count
      J = Worksheets("Data").UsedRange.Rows.Count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Data").UsedRange) = 0 Then J = 0 'Data
      End If
      Set xRg = Worksheets("Sheet1").Range("K1:K" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      Debug.Print CStr(xRg(K).Value)
      If InStr(1, CStr(xRg(K).Value), "Complete") > 0 Then
      Range("A" & xRg(K).Row & ":" & "J" & xRg(K).Row).Copy Destination:=Worksheets("Data").Range("A" & J + 1)
      xRg(K).EntireRow.Delete
      K = K - 1
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
      End Sub

      Sub EnableEvents()
      Application.EnableEvents = True
      End Sub
  • To post as a guest, your comment is unpublished.
    Beth · 1 years ago
    Hi,

    I am using the macro that copies rows of data to another sheet. How might I get the macro to check multiple sheets - sheet 1, 2, 3 and so on, for the same information ("Done" in column G), and bring all relevant rows, across the sheets, to one sheet called "Reporting"?
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Hi Beth,
      Please try the below VA code. Hope it can help. Thank you.

      Sub MoveRowsToSheet()
      Dim xSh As Worksheet
      Dim xRg As Range
      Dim I, J, K As Long
      On Error Resume Next
      If Worksheets("Reporting") Is Nothing Then Exit Sub
      J = Worksheets("Reporting").UsedRange.Rows.Count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Reporting").UsedRange) = 0 Then J = 0
      End If
      I = xRgUsed(xRgUsed.Count).Row
      For Each xSh In Worksheets
      If xSh.Name <> "Reporting" Then
      Set xRg = xSh.UsedRange
      I = xRg(xRg.Count).Row
      Set xRg = Intersect(xRg, Range("G1:G" & I))
      If xRg Is Nothing Then GoTo Ctn
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      If CStr(xRg(K).Value) = "Done" Then
      xRg(K).EntireRow.Copy Destination:=Worksheets("Reporting").Range("A" & J + 1)
      xRg(K).EntireRow.Delete
      If CStr(xRg(K).Value) = "Done" Then
      K = K - 1
      End If
      J = J + 1
      End If
      Next

      End If
      Ctn:
      Next
      Application.ScreenUpdating = True
      End Sub
  • To post as a guest, your comment is unpublished.
    Beth · 1 years ago
    Hi Crystal,

    The code has worked really well. How do I get the code to move a row of data, but only the data between columns A and J?

    I have another table at the side of these rows that I don't want it to move.

    Thanks
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Hi Beth,
      Please try the below VBA code. Hope it can help. Thank you.

      Private Sub Worksheet_Change(ByVal Target As Range)
      Dim xRg As Range
      Dim xCell As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      I = Worksheets("Sheet1").UsedRange.Rows.Count
      J = Worksheets("Data").UsedRange.Rows.Count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Data").UsedRange) = 0 Then J = 0 'Data
      End If
      Set xRg = Worksheets("Sheet1").Range("K1:K" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      Debug.Print CStr(xRg(K).Value)
      If InStr(1, CStr(xRg(K).Value), "Complete") > 0 Then
      Range("A" & xRg(K).Row & ":" & "J" & xRg(K).Row).Copy Destination:=Worksheets("Data").Range("A" & J + 1)
      xRg(K).EntireRow.Delete
      K = K - 1
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
      End Sub

      Sub EnableEvents()
      Application.EnableEvents = True
      End Sub
  • To post as a guest, your comment is unpublished.
    Hector · 1 years ago
    Hi Crystal,


    How do i Modify your code to add another layer to it. so say that if a cell has either "Done" or "Finished" in it, it should move the row. how do i add that modification?
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Dear Hector,
      The below VBA code can help you solve the problem, please have a try. Thank you.

      Sub MoveRowBasedOnCellValue()
      'Updated by Extendoffice 2018/5/22
      Dim xRg As Range
      Dim xCell As Range
      Dim xStr As String
      Dim I As Long
      Dim J As Long
      Dim K As Long
      I = Worksheets("Sheet1").UsedRange.Rows.Count
      J = Worksheets("Sheet2").UsedRange.Rows.Count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
      End If
      Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      xStr = CStr(xRg(K).Value)
      If xStr = "Done" Or xStr = "Finished" Then
      xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
      xRg(K).EntireRow.Delete
      K = K - 1
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
      End Sub
  • To post as a guest, your comment is unpublished.
    Brandon · 1 years ago
    I am using the code that moves the Row to another Tab and deletes the line. I am able to edit the code to work for my purpose, however I have a dropdown that contains 3 choices. Call them One, Two, and Three. If left blank, do nothing and leave the row alone. If dropdown choice One is selected, I am able to get that data moved to tab 1. I just need the additional code added to move Two to 2 and Three to 3. Please Help.
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Dear Brandon,
      The following VBA code can help you to solve the problem. Please put the code into the worksheet (the sheet that contains the drop-down list) code window.

      Private Sub Worksheet_Change(ByVal Target As Range)
      Dim I As Long
      Dim xStr As String
      Application.EnableEvents = False
      If Target.Column = 3 And _
      Target.Validation.Type = 3 And _
      Target.CountLarge = 1 Then
      xStr = Target.Value
      xStr = IIf(xStr = "One", "1", IIf(xStr = "Two", "2", IIf(xStr = "Three", "3", "")))
      I = Worksheets(xStr).UsedRange.Rows.Count
      If I = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets(xStr).UsedRange) = 0 Then I = 0
      End If
      Rows(Target.Row).Copy Destination:=Worksheets(xStr).Range("A" & I + 1)
      Rows(Target.Row).Delete
      End If
      Application.EnableEvents = True
      End Sub

      If the above code doesn't work, please run the below code to enable the event. Hope it can help. Thank you.

      Sub EnableEvents()
      Application.EnableEvents = True
      End Sub
      • To post as a guest, your comment is unpublished.
        Brandon · 1 years ago
        Thanks so much for the reply but I had to remove this functionality. It started going wacky and pulling over data that wasn't supposed to be pulled. Thinking it might not like the conditional formatting I have programmed to change the cell color based on the selection, but I honestly don't know. The fact it's automatic concerns me in the sense I may click the incorrect value in the drop-down. I'd feel much better adding a buttons to do the exact same functionality as I requested above. Not sure how much of an undertaking that would be, but let me know if it's feasible.
  • To post as a guest, your comment is unpublished.
    Casandra · 1 years ago
    Can this same code be used to move the contents when a checkbox is checked instead of typing the word done?
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Dear Casandra,
      Supposing there are Check Boxes(ActiveX Control) in column C of your worksheet, and rows will be moved to Sheet6 when check box is checked. Please apply the below VBA code in your worksheet's code window. Hope it can help. Thank you.

      Function MoveRowBasedOnCheckBox()
      'Updated by Kutools for Excel 2018/5/21
      Cheezy = Worksheets("Sheet6").UsedRange.Rows.Count
      If Cheezy = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Sheet6").UsedRange) = 0 Then Cheezy = 0
      End If
      End Function
      Private Sub CheckBox1_Click()
      Dim I As Long
      Dim xRow As Long
      Dim xRg As Range
      On Error Resume Next
      If Me.CheckBox1 = True Then
      Set xRg = Me.CheckBox1.TopLeftCell
      If xRg.Column = 3 Then
      xRow = Me.CheckBox1.TopLeftCell.Row
      I = Cheezy
      Rows(xRow).Copy Destination:=Worksheets("Sheet6").Range("A" & I + 1)
      Rows(xRow).Delete
      OLEObjects("CheckBox1").Delete
      Call Add(Worksheets("Sheet6"), I + 1)
      End If
      End If
      End Sub
      Private Sub CheckBox2_Click()
      Dim I As Long
      Dim xRow As Long
      Dim xRg As Range
      On Error Resume Next
      If Me.CheckBox2 = True Then
      Set xRg = Me.CheckBox1.TopLeftCell
      If xRg.Column = 3 Then
      xRow = Me.CheckBox2.TopLeftCell.Row
      I = Cheezy
      Rows(xRow).Copy Destination:=Worksheets("Sheet6").Range("A" & I + 1)
      Rows(xRow).Delete
      OLEObjects("CheckBox2").Delete
      Call Add(Worksheets("Sheet6"), I + 1)
      End If
      End If
      End Sub
      'Copy above CheckBox code for other CheckBoxes
      Sub Add(xSheet As Worksheet, ByRef I As Long)
      Dim xRg As Range
      Set xRg = xSheet.Cells(I, 3)
      xSheet.OLEObjects.Add ClassType:="Forms.CheckBox.1", _
      Link:=False, DisplayAsIcon:=False, Left:=xRg.Left, Top:=xRg.Top, _
      Width:=xRg.Width, Height:=xRg.Height
      End Sub
  • To post as a guest, your comment is unpublished.
    julia · 1 years ago
    This is wonderful! Thank you!!

    I'm currently using the following VBA (I'm also new to this). 1-I want it to update automatically without manually having to press F5. 2- I ONLY want to copy cells A - J from the "Production Board" to the "Data" Sheet. 3- I want to delete the ENTIRE row from the "Production Board" once it has been copied over to the "Data" sheet

    Sub Cheezy()
    'Updated by Kutools for Excel 2017/8/28
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Production Board").UsedRange.Rows.Count
    J = Worksheets("Data").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Data").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Production Board").Range("K1:K" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
    If CStr(xRg(K).Value) = "Complete" Then
    xRg(K).EntireRow.Copy Destination:=Worksheets("Data").Range("A" & J + 1)
    xRg(K).EntireRow.Delete
    If CStr(xRg(K).Value) = "Complete" Then
    K = K - 1
    End If
    J = J + 1
    End If
    Next
    Application.ScreenUpdating = True
    End Sub
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Dear Julia,
      Please try the following VBA code. Hope it can help. Thank you.

      Private Sub Worksheet_Change(ByVal Target As Range)
      Dim xRg As Range
      Dim xCell As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      I = Worksheets("Production Board").UsedRange.Rows.Count 'Production Board
      J = Worksheets("Data").UsedRange.Rows.Count 'Data
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Data").UsedRange) = 0 Then J = 0 'Data
      End If
      Set xRg = Worksheets("Production Board").Range("K1:K" & I) 'Production Board
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      Debug.Print CStr(xRg(K).Value)
      If InStr(1, CStr(xRg(K).Value), "Complete") > 0 Then
      Range("A" & xRg(K).Row & ":" & "J" & xRg(K).Row).Copy Destination:=Worksheets("Data").Range("A" & J + 1)
      xRg(K).EntireRow.Delete
      K = K - 1
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
      End Sub

      Sub EnableEvents()
      Application.EnableEvents = True
      End Sub
      • To post as a guest, your comment is unpublished.
        Kimberly · 1 years ago
        Hi Crystal,

        Is it possible to do this but with nonspecific sheet names? I tried to set the following but it didn't work. Thank you!
        Private Sub Worksheet_Change(ByVal Target As Range)
        Dim xRg As Range
        Dim xCell As Range
        Dim I As Long
        Dim J As Long
        Dim K As Long
        Dim sName As String
        Dim s2Name As String
        sName = Sheets(2).Name
        s2Name = Sheets(3).Name
        I = Worksheets("sName").UsedRange.Rows.Count 'sName
        J = Worksheets("s2Name").UsedRange.Rows.Count 's2Name
        If J = 1 Then
        If Application.WorksheetFunction.CountA(Worksheets("s2Name").UsedRange) = 0 Then J = 0 's2Name
        End If
        Set xRg = Worksheets("sName").Range("D1:D" & I) 'sName
        On Error Resume Next
        Application.ScreenUpdating = False
        For K = 1 To xRg.Count
        Debug.Print CStr(xRg(K).Value)
        If InStr(1, CStr(xRg(K).Value), "Proposal") > 0 Then
        Range("A" & xRg(K).Row & ":" & "J" & xRg(K).Row).Copy Destination:=Worksheets("s2Name").Range("A" & J + 1)
        xRg(K).EntireRow.Delete
        K = K - 1
        J = J + 1
        End If
        Next
        Application.ScreenUpdating = True
        End Sub

        Sub EnableEvents()
        Application.EnableEvents = True
        End Sub
  • To post as a guest, your comment is unpublished.
    Wendy · 1 years ago
    This is fantastic but how can I combine them (from how similar they it appears it can be done, I just can't get it spliced in right to make it work)? What I am trying to do is when the word is "Sold" it moves the row but when the word is "Partial" it copies the row (words are both in the same column). Thanks for your help.
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Dear Wendy,
      Supposing rows will be moved or copied from Sheet1 to Sheet2 based on specified values, the following VBA code can help you solve the problem. Thank you for your comment.

      Sub MoveRowBasedOnCellValue()
      'Updated by Extendoffice 2018/05/21
      Dim xRg As Range
      Dim xCell As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      I = Worksheets("Sheet1").UsedRange.Rows.Count
      J = Worksheets("Sheet2").UsedRange.Rows.Count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
      End If
      Set xRg = Worksheets("Sheet1").Range("E1:E" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      If CStr(xRg(K).Value) = "Sold" Then
      xRg(K).EntireRow.Cut Destination:=Worksheets("Sheet2").Range("A" & J + 1)
      xRg(K).EntireRow.Delete
      K = K - 1
      J = J + 1
      ElseIf CStr(xRg(K).Value) = "Partial" Then
      xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
      End Sub
  • To post as a guest, your comment is unpublished.
    Shane · 1 years ago
    I can't get it to work. At all. Nothing happens. The screen flashes once real quick like something did happen, but when I go to the tab the lines were supposed to be copied to, it's still blank. Here are the differences between what I have and your example:
    1. First 2 rows are freeze-paned.
    2. I need all this to start on row for on source sheet, and row 4 on destination sheet - They both have the first 2 rows freeze-paned (for titles).
    I need it copied and not moved, so I used your second example, and made my modifications.

    Here is what I'm using:

    Sub WEST()
    'Updated by Kutools for Excel 2017/8/28
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Mar 18 CIA").UsedRange.Rows.Count
    J = Worksheets("West").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("West").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Mar 18 CIA").Range("E4:E" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
    If CStr(xRg(K).Value) = "West" Then
    xRg(K).EntireRow.Copy Destination:=Worksheets("West").Range("A" & J + 1)
    J = J + 1
    End If
    Next
    Application.ScreenUpdating = True
    End Sub
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Good day,
      Your code works well. Please check if case sensitive exist between cells in column E and the specified word "West". Thank you.
  • To post as a guest, your comment is unpublished.
    Blake Abrahamson · 1 years ago
    Thanks Crystal, this code was working great for me last week but it seems to be giving me issues this week. I have multiple items that update to a "completed" status when I open the workbook and all of these items should be moving but instead the code seems to error out.... I just get the blue spinning circle and excel eventually stops responding. Is there something I need to do to the code so that it can handle multiple rows at the same time?


    Sub Complete()
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("New-Open EFR'S").UsedRange.Rows.Count
    J = Worksheets("Completed EFR's").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Completed EFR's").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("New-Open EFR'S").Range("O1:O" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
    If CStr(xRg(K).Value) = "Complete" Then
    xRg(K).EntireRow.Copy Destination:=Worksheets("Completed EFR's").Range("A" & J + 1)
    xRg(K).EntireRow.Delete
    If CStr(xRg(K).Value) = "Complete" Then
    K = K - 1
    End If
    J = J + 1
    End If
    Next
    Application.ScreenUpdating = True
    End Sub
    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Good Day,
      Please change the first line in the code to "Private Sub Worksheet_Change(ByVal Target As Range)", and change "Complete" to "Completed". See code below:

      Private Sub Worksheet_Change(ByVal Target As Range)
      Dim xRg As Range
      Dim xCell As Range
      Dim I As Long
      Dim J As Long
      Dim K As Long
      I = Worksheets("New-Open EFR'S").UsedRange.Rows.Count
      J = Worksheets("Completed EFR's").UsedRange.Rows.Count
      If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Completed EFR's").UsedRange) = 0 Then J = 0
      End If
      Set xRg = Worksheets("New-Open EFR'S").Range("O1:O" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
      If CStr(xRg(K).Value) = "Completed" Then
      xRg(K).EntireRow.Copy Destination:=Worksheets("Completed EFR's").Range("A" & J + 1)
      xRg(K).EntireRow.Delete
      If CStr(xRg(K).Value) = "Complete" Then
      K = K - 1
      End If
      J = J + 1
      End If
      Next
      Application.ScreenUpdating = True
      End Sub
  • To post as a guest, your comment is unpublished.
    Sabina · 1 years ago
    Hi Crystal,

    Thank you very much for all your help with my spreadsheet.

    Could you please advice if i should remove conditional formatting from the spreadsheet to make the automated VBA code work and do not freeze the entire file.

    Thank you,

    Sabina