Note: The other languages of the website are Google-translated. Back to English
Registo de cliente  or Registe-se  or

Como mover uma linha inteira para outra planilha com base no valor da célula no Excel?

Para mover uma linha inteira para outra planilha com base no valor da célula, este artigo o ajudará.

Mova a linha inteira para outra folha com base no valor da célula com código VBA
Mova a linha inteira para outra planilha com base no valor da célula com o Kutools para Excel

Mova a linha inteira para outra folha com base no valor da célula com código VBA

Como mostrado na captura de tela abaixo, você precisa mover a linha inteira da Planilha1 para a Planilha2 se uma palavra específica “Concluído” existir na coluna C. Você pode tentar o seguinte código VBA. 1. Pressione outro+ F11 simultaneamente para abrir o Microsoft Visual Basic para Aplicações janela.

2. Na janela Microsoft Visual Basic for Applications, clique em inserção > Módulo. Em seguida, copie e cole o código VBA abaixo na janela.

VBA code 1: Move entire row to another sheet based on cell value

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

Importante: No código, Sheet1 é a planilha que contém a linha que você deseja mover. E Sheet2 é a planilha de destino onde você localizará a linha. “C: C”É a coluna que contém o determinado valor e a palavra“Feito”É o valor certo no qual você moverá a linha. Altere-os de acordo com suas necessidades.

3. aperte o F5 para executar o código, a linha que atende aos critérios na Planilha1 será movida para a Planilha2 imediatamente. Importante: O código VBA acima excluirá linhas dos dados originais após mover para uma planilha especificada. Se você deseja apenas copiar linhas com base no valor da célula, em vez de excluí-las. Por favor, aplique o código VBA 2 abaixo.

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

Mova a linha inteira para outra planilha com base no valor da célula com o Kutools para Excel

Se você é um novato no código VBA. Aqui eu apresento o Selecione células específicas utilidade de Kutools for Excel. Com este utilitário, você pode selecionar facilmente todas as linhas com base em um determinado valor de célula ou diferentes valores de célula em uma planilha e copiar as linhas selecionadas para a planilha de destino conforme necessário. Faça o seguinte.

Antes de aplicar Kutools for Excel, Por favor baixe e instale primeiro.

1. Selecione a lista de colunas que contém o valor da célula em que moverá as linhas com base e clique em Kutools > Selecionar > Selecione células específicas. Veja a imagem: 2. Na abertura Selecione células específicas caixa de diálogo, escolha Linha inteira no Tipo de seleção seção, selecione É igual a no Tipo específico lista suspensa, insira o valor da célula na caixa de texto e clique no botão OK botão.

Outro Selecione células específicas A caixa de diálogo aparece para mostrar o número de linhas selecionadas e, enquanto isso, todas as linhas contêm o valor especificado na coluna selecionada. Veja a imagem: 3. aperte o Ctrl + C para copiar as linhas selecionadas e, em seguida, colá-las na planilha de destino necessária. Importante: Se você deseja mover linhas para outra planilha com base em dois valores de células diferentes. Por exemplo, mova as linhas com base nos valores das células "Concluído" ou "Processando", você pode ativar o Or condição no Selecione células específicas caixa de diálogo como a imagem abaixo mostrada: Se você quiser ter um teste gratuito (30 dias) deste utilitário, por favor clique para fazer o downloade, em seguida, aplique a operação de acordo com as etapas acima.

As melhores ferramentas de produtividade para escritório

O Kutools for Excel resolve a maioria dos seus problemas e aumenta sua produtividade em 80%

• armadilha para peixes: Insira rapidamente fórmulas complexas, gráficos e qualquer coisa que você tenha usado antes; Criptografar células com senha; Criar lista de discussão e enviar emails ...
• Barra Super Fórmula (edite facilmente várias linhas de texto e fórmula); Layout de leitura (ler e editar facilmente um grande número de células); Colar na faixa filtrada...
• Mesclar células / linhas / colunas sem perder dados; Dividir o conteúdo das células; Combinar linhas / colunas duplicadas... Evite células duplicadas; Comparar intervalos...
• Selecione Duplicado ou Único Linhas; Selecione linhas em branco (todas as células estão vazias); Super Find e Fuzzy Find em muitos livros; Seleção aleatória ...
• Cópia exata Várias células sem alterar a referência da fórmula; Criação automática de referências para várias folhas; Inserir marcadores, Caixas de seleção e mais ...
• Extrair Texto, Adicionar texto, remover por posição, Remover Espaço; Criar e imprimir subtotais de paginação; Converter entre conteúdo de células e comentários...
• Super Filtro (salvar e aplicar esquemas de filtro a outras planilhas); Classificação Avançada por mês / semana / dia, frequência e mais; Filtro Especial por negrito, itálico ...
• Combine pastas de trabalho e planilhas; Mesclar tabelas com base em colunas-chave; Divida os dados em várias folhas; Conversão em lote de xls, xlsx e PDF...
• Mais de 300 recursos poderosos. Suporta Office / Excel 2007-2019 e 365. Suporta todos os idiomas. Fácil implantação em sua empresa ou organização. Teste gratuito de 30 dias com recursos completos. Garantia de devolução do dinheiro em 60 dias. Guia do Office traz interface com guias para o Office e torna seu trabalho muito mais fácil

• Habilite a edição e leitura com guias em Word, Excel, PowerPoint, Publisher, Access, Visio e Project.
• Abra e crie vários documentos em novas guias da mesma janela, em vez de em novas janelas.
• Aumenta sua produtividade em 50% e reduz centenas de cliques do mouse para você todos os dias! Say something here...
symbols left.
or post as a guest, but your post won't be published automatically.
• To post as a guest, your comment is unpublished.
· 2 days ago
How can i use that same VBA code for moving the row to another sheet but to an specific range.
I have a table in sheet LOG that i want to move to sheet HISTORY, in that sheet i will move some rows to range A through E and others to range H through L.

I have various Macros, one for each condition, I would just like for them to be all in the same sheet just different Ranges

Sub MoveCompleted()
'Move completed strategies
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Log").UsedRange.Rows.Count
J = Worksheets("Completed HST").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Completed HST").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Log").Range("D1:D" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Strategy Complete" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Completed HST").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Strategy 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.
· 1 months ago
Hi, I have followed everything as above but the macro does not work. Any help appreciated.
• To post as a guest, your comment is unpublished.
· 28 days ago
Hi Julie Shaw,
Did you get any error prompt? I need to know more specific about your issue, such as your Excel version. And if you don't mind, try to create your data in a new workbook and test the feature again.
• To post as a guest, your comment is unpublished.
· 1 months ago
Hi there, massive thanks for the macro! It does exactly what I wanted to achieve, however it doesn't work without 'Run' command /or assigning it to a button. Any guidance what should be changed in the code to get the results once a specific (trigger) word is inputted/chosen from a dropdown list?

• To post as a guest, your comment is unpublished.
· 28 days ago
Hi Zuza,
The VBA below can help. After selecting a specific word from a drop-down list and click on any cell in the worksheet, or manually input a certain word and press the Enter key, the code will be triggered and the entire row will be moved to Sheet2.

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Updated by Extendoffice 2021/12/24 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
• To post as a guest, your comment is unpublished.
· 1 months ago
Hey, I was wondering if there is any code for more than 2 string variables can be selected and moved to a separate sheet.

I am trying to move multiple rows to different sheets (if jan, the move to sheet 2, if feb then move to sheet 3 and so on).. am i going in a correct path?

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("A1:N15" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "jan" Then 'i used jan here
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
J = J + 1
End If
If CStr(xRg(K).Value) = "feb" Then 'i used feb here
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet3").Range("A" & J + 1)
J = J + 1
End If
If CStr(xRg(K).Value) = "march" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet4").Range("A" & J + 1)
J = J + 1
End If
If CStr(xRg(K).Value) = "april" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet5").Range("A" & J + 1)
J = J + 1
End If
If CStr(xRg(K).Value) = "may" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet6").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub

can u please tell me what i am doing wrong, this is just skipping and going to end if even when I have the string Jan in my excel sheet

data below

sam    sam    HIGH     HIGH     HIGH     HIGH
jan     1    0.130611886    0.087994734    0.950128831    0.960553872    0.532745745    0.549815838
jan     2    0.622211575    0.416777097    0.870095338    0.893911135    0.681240756    0.002856528
jan     4    0.112846199    0.424462482    0.06927836    0.95756427    0.475747388    0.653089325
jan     5    0.803092732    0.570889606    0.852751909    0.825886882    0.632992726    0.179768711
feb     6    0.67067967    0.608635425    0.2455054    0.124080989    0.329116168    0.61109087
feb    7    0.568288159    0.585665038    0.618643419    0.515624415    0.504291309    0.503648256
feb    8    0.907326024    0.908688396    0.81021464    0.290967182    0.374706207    0.70068252
march     9    0.183965182    0.599929918    0.487607073    0.552583064    0.945990901    0.403933164
march     10    0.11689916    0.911665    0.866692282    0.699833953    0.057164811    0.918145611
march     11    0.960062757    0.392939505    0.701406459    0.454092566    0.989942965    0.431661601
april     12    0.725952092    0.209348467    0.616936454    0.416907252    0.543104147    0.875447934
april     13    0.137695707    0.657915059    0.229235091    0.121599503    0.334413595    0.462686543
april     14    0.72367305    0.043006438    0.882917392    0.036653529    0.79101546    0.268452369

• To post as a guest, your comment is unpublished.
· 28 days ago
Hi,
I have tried the code you provided and it works well for your needs. What is the problem you are experiencing?
• To post as a guest, your comment is unpublished.
· 1 months ago
Using the copy/paste code, how would I copy only a certain cell rather than the entire row?

This is the code I'm using:

Sub Cheezy()
'Updated by Extendoffice 20210806
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("Zoology")
Set xLWS = Worksheets("Current Map Assignments") 'Map
Set xEWS = Worksheets("Current Rank Assignments") 'Rank
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("AM1:AM" & xDR)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Map" 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
xLR = xLR + 1
ElseIf CStr(xRg(K).Value) = "Rank" 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
xER = xER + 1
End If
Next K
Application.ScreenUpdating = True
End Sub
• To post as a guest, your comment is unpublished.
· 2 months ago
Hi Crystal

thanks for the code. but i am having some issues

Sub Cheezy()
'Updated by Extendoffice 20210806
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("Internal Staff")
Set xLWS = Worksheets("Available") 'Active
Set xEWS = Worksheets("Sheet3") 'Resigned
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("P1:P" & xDR)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Active" 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) = "Resigned" 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

this is to track my active and resigned staffs.

i have created a button for this code. however, when i click on the button, it only moved a certain no of rows only. For eg, if i have 10 rows that are resigned, it moves only 8 rows then i need to reclick on the button again for the balance 2 rows to sheet 3.

In addition, there are certain rows that was skipped.

For eg: row 1-10 = yes, but moved was row 1-4 then 9-10

i need to click again on the button for row 5-8 to be moved

• To post as a guest, your comment is unpublished.
· 1 months ago
Hi, zorro,
The VBA below can help to solve the problem. Please have a try.
Sub MoveRows() 'Updated by Extendoffice 20211125 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 xDtlRg As Range Dim xDC As Long Dim K As Long Dim xC1 As Long Dim xFNum As Long Set xDWS = Worksheets("Internal Staff") Set xLWS = Worksheets("Available") 'Active Set xEWS = Worksheets("Sheet3") 'Resigned 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("P1:P" & xDR) On Error Resume Next Set xDtlRg = Null Application.ScreenUpdating = False For K = 1 To xRg.Count If CStr(xRg(K).Value) = "Active" 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 If (xDtlRg Is Nothing) Then Set xDtlRg = xRg(K).EntireRow Else Set xDtlRg = Application.Union(xDtlRg, xRg(K).EntireRow) End If xLR = xLR + 1 ElseIf CStr(xRg(K).Value) = "Resigned" 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 If (xDtlRg Is Nothing) Then Set xDtlRg = xRg(K).EntireRow Else Set xDtlRg = Application.Union(xDtlRg, xRg(K).EntireRow) End If xER = xER + 1 End If Next K If (xDtlRg Is Nothing) Then Else xDtlRg.Select xDtlRg.Delete (xlShiftUp) xDWS.Range("A1").Select End If Application.ScreenUpdating = True End Sub
• To post as a guest, your comment is unpublished.
· 2 months ago
Hi Crystal, you are so helpful in my getting the VBA done for my excel.

I am using you vba code as follows to track my staffs record for resigned:

Sub Cheezy()
'Updated by Extendoffice 20210806
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("Internal staff")
Set xLWS = Worksheets("Available") 'Yes
Set xEWS = Worksheets("Sheet3") 'Resigned
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("P1:P" & xDR)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Yes" 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) = "Resigned" 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

However, when i click on the button i created for this code,they only move a certain rows. for eg, i have 10 resigned staffs, but the code only move 8, then i need to reclick the button again for them to move the balance 2 rows.

• To post as a guest, your comment is unpublished.
· 5 months ago
Hi Crystal,

In this part of the code:

xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)

Does the "A" refer to the column that will be copied into sheet2?

I'm trying to copy in column B, but I'm not succeeding.
• To post as a guest, your comment is unpublished.
· 4 months ago
Hi,
This part of code represents the destination where to place the copied values.
If you want to copy rows based on values in column B, change the "C" to "B" in this part of the code:
Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
• To post as a guest, your comment is unpublished.
· 5 months ago
Hey,

Thanks for the code, 1 question is it possible to change it so i searches 2 diff values? No i use 2 macro to run after each other, but this slows my file down.
• To post as a guest, your comment is unpublished.
· 5 months ago
Hi kevin,
The below code handles 2 different values: Supposing rows in Sheet1 will be moved automatically based on two values "LIVE" and "ENDED" in column C. After running the code, the row containing "LIVE" goes to "Sheet2", and the row containing "ENDED" goes to "Sheet3".

Sub Cheezy() 'Updated by Extendoffice 20210806 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.
· 5 months ago
• To post as a guest, your comment is unpublished.
· 6 months ago
hello
check this code plz
Sub macro()

Dim xRg As Range
Dim xCell As Range
Dim xRRg1 As Range
Dim xRRg2 As Range

Dim xAAWS As Worksheet
Dim xAWS As Worksheet
Dim xBWS As Worksheet
Dim xCWS As Worksheet
Dim xDWS As Worksheet
Dim xEWS As Worksheet
Dim xFWS As Worksheet
Dim xGWS As Worksheet
Dim xHWS As Worksheet
Dim xIWS As Worksheet
Dim xJWS As Worksheet
Dim xKWS As Worksheet
Dim xLWS As Worksheet
Dim xMWS As Worksheet
Dim xNWS As Worksheet
Dim xPWS As Worksheet
Dim xQWS As Worksheet
Dim xRWS As Worksheet
Dim xSWS As Worksheet
Dim xTWS As Worksheet
Dim xUWS As Worksheet
Dim xVWS As Worksheet
Dim xWWS As Worksheet
Dim xXWS As Worksheet
Dim xYWS As Worksheet
Dim xZWS As Worksheet

Dim xAAR, xAR, xBR, xCR, xDR, xER, xFR, xGR, xHR, xIR, xJR, xKR, xLR, xMR, xNR, xPR, xQR, xRR, xSR, xTR, xUR, xVR, xWR, xXR, xYR, xZR As Long

Dim xDC As Long
Dim K As Long
Dim xC1 As Long
Dim xFNum As Long

Set xAAWS = Worksheets("Sheet1") 'Ô?Ê ÇÕá?
Set xAWS = Worksheets("Sheet2") 'åÒ??å ÈÓÊå ÈäÏ?
Set xBWS = Worksheets("Sheet3") 'åÒ?äå ÊÈá?ÛÇÊ
Set xCWS = Worksheets("Sheet4") 'åÒ?äå ÇÏÇÔ
Set xWS = Worksheets("Sheet5") 'åÒ?äå ÛÑÝå ÞÕÇÈ?
Set xEWS = Worksheets("Sheet6") 'åÒ?äå ÍÞæÞ
Set xFWS = Worksheets("Sheet7") 'åÒ?äå ÏÑãÇä
Set xGWS = Worksheets("Sheet8") 'åÒ?äå ÓÝÑæÝæÞ ÇáÚÇÏå ãÇãæÑ?Ê ÏÇÎá ˜ÔæÑ
Set xHWS = Worksheets("Sheet9") 'åÒ?äå Ç?ÇÈ æÐåÇÈ
Set xIWS = Worksheets("Sheet10") 'ÂÈÜÜÜÜÜÜÜÏÇÑÎÜÜÜÜÜÜÇäå
Set xJWS = Worksheets("Sheet11") 'åÒíäå ÑÓäá æÙ?Ýå
Set xKWS = Worksheets("Sheet12") 'ÊäÙíÜÜÜÜÜÝ æ ÈÜÜÇÛÈÜÜÜÇäÜÜÜÜÜí
Set xLWS = Worksheets("Sheet13") 'åÒíäå ÌÔä æÐíÑÇí?
Set xMWS = Worksheets("Sheet14") 'åÒíäå ÓÊ ÊáÝä
Set xNWS = Worksheets("Sheet15") 'åÒíäå äæÔÊ ÇÝÒÇÑ
Set xPWS = Worksheets("Sheet16") 'åÒíäå ÈÇä˜í
Set xQWS = Worksheets("Sheet17") 'ÊÚãíÑ æ äåÏÇÑí ÇËÜÜÜÜÜÜÇËå
Set xRWS = Worksheets("Sheet18") 'åÒ?äå ÊÚã?Ñ æäåÏÇÑí ÓÇÎÊãÇä
Set xSWS = Worksheets("Sheet19") 'åÒ?äå ÊÚã?Ñ æäåÏÇÑí ÊÇÓ?ÓÇÊ
Set xTWS = Worksheets("Sheet20") 'åÒ?äå ÊÚã?Ñ æÓÇÆØ äÞáíå
Set xUWS = Worksheets("Sheet21") 'åÒ?äå ÊÌå?ÒÇÊ ÑÇ?Çäå
Set xVWS = Worksheets("Sheet22") 'åÒ?äå ÓæÎÊ æÓÇÆØ äÞá?å
Set xWWS = Worksheets("Sheet23") 'åÒ?äå Íãá æäÞá æÊÎá?å æÈÇÑ?Ñ?
Set xXWS = Worksheets("Sheet24") 'ÓÇíÑ åÒíäå åÇ
Set xYWS = Worksheets("Sheet25") 'åÒíäå ÍÞ ÕäÏÞÏÇÑ?
Set xZWS = Worksheets("Sheet26") 'åÒíäå áÈÇÓ

xAAR = xAAWS.UsedRange.Rows.Count
xAR = xAWS.UsedRange.Rows.Count
xBR = xBWS.UsedRange.Rows.Count
xCR = xCWS.UsedRange.Rows.Count
xDR = xWS.UsedRange.Rows.Count
xER = xEWS.UsedRange.Rows.Count
xFR = xFWS.UsedRange.Rows.Count
xGR = xGWS.UsedRange.Rows.Count
xHR = xHWS.UsedRange.Rows.Count
xIR = xIWS.UsedRange.Rows.Count
xJR = xJWS.UsedRange.Rows.Count
xKR = xKWS.UsedRange.Rows.Count
xLR = xLWS.UsedRange.Rows.Count
xMR = xMWS.UsedRange.Rows.Count
xNR = xNWS.UsedRange.Rows.Count
xPR = xPWS.UsedRange.Rows.Count
xQR = xQWS.UsedRange.Rows.Count
xRR = xRWS.UsedRange.Rows.Count
xSR = xSWS.UsedRange.Rows.Count
xTR = xTWS.UsedRange.Rows.Count
xUR = xUWS.UsedRange.Rows.Count
xVR = xVWS.UsedRange.Rows.Count
xWR = xWWS.UsedRange.Rows.Count
xXR = xXWS.UsedRange.Rows.Count
xYR = xYWS.UsedRange.Rows.Count
xZR = xZWS.UsedRange.Rows.Count
xDC = xAAWS.UsedRange.Columns.Count

If xAR = 1 Then
If Application.WorksheetFunction.CountA(xAWS.UsedRange) = 0 Then xAR = 0
End If
If xBR = 1 Then
If Application.WorksheetFunction.CountA(xBWS.UsedRange) = 0 Then xBR = 0
End If
If xCR = 1 Then
If Application.WorksheetFunction.CountA(xCWS.UsedRange) = 0 Then xCR = 0
End If
If xDR = 1 Then
If Application.WorksheetFunction.CountA(xWS.UsedRange) = 0 Then xDR = 0
End If
If xER = 1 Then
If Application.WorksheetFunction.CountA(xEWS.UsedRange) = 0 Then xER = 0
End If
If xFR = 1 Then
If Application.WorksheetFunction.CountA(xFWS.UsedRange) = 0 Then xFR = 0
End If
If xGR = 1 Then
If Application.WorksheetFunction.CountA(xGWS.UsedRange) = 0 Then xGR = 0
End If
If xHR = 1 Then
If Application.WorksheetFunction.CountA(xHWS.UsedRange) = 0 Then xHR = 0
End If
If xIR = 1 Then
If Application.WorksheetFunction.CountA(xIWS.UsedRange) = 0 Then xIR = 0
End If
If xJR = 1 Then
If Application.WorksheetFunction.CountA(xJWS.UsedRange) = 0 Then xJR = 0
End If
If xKR = 1 Then
If Application.WorksheetFunction.CountA(xKWS.UsedRange) = 0 Then xKR = 0
End If
If xLR = 1 Then
If Application.WorksheetFunction.CountA(xLWS.UsedRange) = 0 Then xLR = 0
End If
If xMR = 1 Then
If Application.WorksheetFunction.CountA(xMWS.UsedRange) = 0 Then xMR = 0
End If
If xNR = 1 Then
If Application.WorksheetFunction.CountA(xNWS.UsedRange) = 0 Then xNR = 0
End If
If xPR = 1 Then
If Application.WorksheetFunction.CountA(xPWS.UsedRange) = 0 Then xPR = 0
End If
If xQR = 1 Then
If Application.WorksheetFunction.CountA(xQWS.UsedRange) = 0 Then xQR = 0
End If
If xRR = 1 Then
If Application.WorksheetFunction.CountA(xRWS.UsedRange) = 0 Then xRR = 0
End If
If xSR = 1 Then
If Application.WorksheetFunction.CountA(xSWS.UsedRange) = 0 Then xSR = 0
End If
If xTR = 1 Then
If Application.WorksheetFunction.CountA(xTWS.UsedRange) = 0 Then xTR = 0
End If
If xUR = 1 Then
If Application.WorksheetFunction.CountA(xUWS.UsedRange) = 0 Then xUR = 0
End If
If xVR = 1 Then
If Application.WorksheetFunction.CountA(xVWS.UsedRange) = 0 Then xVR = 0
End If
If xWR = 1 Then
If Application.WorksheetFunction.CountA(xWWS.UsedRange) = 0 Then xWR = 0
End If
If xXR = 1 Then
If Application.WorksheetFunction.CountA(xXWS.UsedRange) = 0 Then xXR = 0
End If
If xYR = 1 Then
If Application.WorksheetFunction.CountA(xYWS.UsedRange) = 0 Then xYR = 0
End If
If xZR = 1 Then
If Application.WorksheetFunction.CountA(xZWS.UsedRange) = 0 Then xZR = 0
End If

Set xRg = xAAWS.Range("C1:C" & xAAR)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count

If CStr(xRg(K).Value) = "packing" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xAWS.Range("A" & xAR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xAR = xAR + 1

ElseIf CStr(xRg(K).Value) = " Advertising" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xBWS.Range("A" & xBR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xBR = xBR + 1

ElseIf CStr(xRg(K).Value) = "reward" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xCWS.Range("A" & xCR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xCR = xCR + 1

ElseIf CStr(xRg(K).Value) = " Butcher shop" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xWS.Range("A" & xDR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xDR = xDR + 1

ElseIf CStr(xRg(K).Value) = " Rights" 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

ElseIf CStr(xRg(K).Value) = " treatment" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xFWS.Range("A" & xFR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xFR = xFR + 1

ElseIf CStr(xRg(K).Value) = " Travel and mission" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xGWS.Range("A" & xGR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xGR = xGR + 1

ElseIf CStr(xRg(K).Value) = " Transportation" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xHWS.Range("A" & xHR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xHR = xHR + 1

ElseIf CStr(xRg(K).Value) = " Juice House" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xIWS.Range("A" & xIR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xIR = xIR + 1

ElseIf CStr(xRg(K).Value) = " Duty personnel" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xJWS.Range("A" & xJR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xJR = xJR + 1

ElseIf CStr(xRg(K).Value) = " Cleaning and gardening" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xKWS.Range("A" & xKR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xKR = xKR + 1

ElseIf CStr(xRg(K).Value) = " Celebration and reception" 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) = " Phone" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xMWS.Range("A" & xMR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xMR = xMR + 1

ElseIf CStr(xRg(K).Value) = " Stationery" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xNWS.Range("A" & xNR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xNR = xNR + 1

ElseIf CStr(xRg(K).Value) = " Bank charges" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xPWS.Range("A" & xPR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xPR = xPR + 1

ElseIf CStr(xRg(K).Value) = " Repair and maintenance of furniture" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xQWS.Range("A" & xQR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xQR = xQR + 1

ElseIf CStr(xRg(K).Value) = " Building maintenance" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xRWS.Range("A" & xRR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xRR = xRR + 1

ElseIf CStr(xRg(K).Value) = " Facility maintenance" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xSWS.Range("A" & xSR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xSR = xSR + 1

ElseIf CStr(xRg(K).Value) = " Vehicle maintenance" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xTWS.Range("A" & xTR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xTR = xTR + 1

ElseIf CStr(xRg(K).Value) = " Computer equipment " Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xUWS.Range("A" & xUR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xUR = xUR + 1

ElseIf CStr(xRg(K).Value) = " Vehicle fuel" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xVWS.Range("A" & xVR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xVR = xVR + 1

Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xWWS.Range("A" & xWR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xWR = xWR + 1

ElseIf CStr(xRg(K).Value) = " other costs" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xXWS.Range("A" & xXR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xXR = xXR + 1

ElseIf CStr(xRg(K).Value) = " cash desk " Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xYWS.Range("A" & xYR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xYR = xYR + 1

ElseIf CStr(xRg(K).Value) = "dress" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xZVWS.Range("A" & xZR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xZR = xZR + 1

End If
Next K
Application.ScreenUpdating = True
End Sub

• To post as a guest, your comment is unpublished.
· 6 months ago
Hello everyone
How to create a bet inside sheet one
For example, column E1, which has the same name as the different sheets, can be saved by writing each row in the tabs of the same name with that row.
Thank You
• To post as a guest, your comment is unpublished.
· 6 months ago
Similar to the attachment
• To post as a guest, your comment is unpublished.
· 6 months ago
Hello everyone,

thank you for these codes, they are working perfectly in almost all situations. However, I'm having an issue with the copy and past one. It's not pasting on the next empty cell, but on the next non-active (never used) cell. I've tried to clear the content from the editing menu, but even after doing that, closing and opening the file, it keeps pasting only from the first cell that was never used before. Does anyone have any suggestion or a solution on what's happening?

I would appreciate any help.
• To post as a guest, your comment is unpublished.
· 8 months ago
I'm doing somewhat of the same thing Miranda did below; however I have a drop down box on main sheet that designates a column (Column M) with 6 choices. I wanted to copy those rows to the designated sheet. Like this: If it says Complete - copy row to Sheet3; In Review - copy row to Sheet4; Not Yet Rec'd - copy row to Sheet5; Not Shell Complete - copy row to Sheet6; Partial - copy row to Sheet7; Send Request - copy row to Sheet8). I also want to remove it from one sheet except master sheet (Sheet1) to another each time the designation changes. Once it reaches "Complete" the designation stops there.
• To post as a guest, your comment is unpublished.
· 8 months ago
I have got this to work on a spreadsheet I am working on, but is there a way to have it automatically move over rows, but only copy not delete. Each row has a unique reference in column A which could help.

When I tried it either copies the entries it has already moved over or crash from continuously copying the rows over.

• To post as a guest, your comment is unpublished.
· 8 months ago
Hiya

Thanks for this - it's to helpful. I wondered if I could ask - would this VBA code be impacted, when using columns which are using formula?

For example, when using the VBA code 2: Copy entire row to another sheet based on cell value I am wanting to copy rows from one sheet to another, based on whether column J has a "Y" entered. This "Y" is entered into the cells in column J, using the IF formula. When I run the VBA, it copies over the row accurately, however parts of the row it transfers, are not transferred correctly i.e. column A of the row is correct but column B is the information from 5 rows below.

I hope I'm making some kind of sense!

I wonder if sending you the spreadsheet would help?

Thanks

Lucy Hughes
• To post as a guest, your comment is unpublished.
· 9 months ago
How can I modify the VBA to clear the contents/delete cells just from the columns in the original sheet that I specify, rather than the entire row? I specified just which columns to pull from on the copy side, but in the next line if I do anything other than Entirerow delete it doesn't work.
• To post as a guest, your comment is unpublished.
· 9 months ago
This is very helpful, although I need more help please. When I used the instructions in "Move Entire Row To Another Sheet Based On Cell Value With VBA Code", it worked except that:
1. Not automatic. I have to go to the Module and click F5 for the code to run and move it to Completed cases. Any way this should be automatic, like when I click the dropdown, it should move right away.
• To post as a guest, your comment is unpublished.
· 21 days ago
Hi,
Try the following VBA code.
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Updated by Kutools for Excel 2021/12/31 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
• To post as a guest, your comment is unpublished.
· 10 months ago
Hello, This is extremely helpful, and I have been able to get it to work in a few examples. But in the case of it not deleting the value in the first sheet, is there a way for it to not copy the same info into Sheet2 each time I run the macro?
• To post as a guest, your comment is unpublished.
· 9 months ago
Hi Matthew,
There are two codes in the post. The VBA code 1 is for moving rows, and the VBA code 2 is for copying rows. If you want to move rows and delete the values in the original sheet, please apply the VBA code 1.
• To post as a guest, your comment is unpublished.
· 10 months ago
Hey all! I LOVE the example where the items are valued as "done", but I have a similar situation, where I don't have "done", but a completion date instead, and I'm looking to have items that have been completed for 30 days (random number) to be relocated to an archive sheet. Any tips on how that might go? Thanks!
• To post as a guest, your comment is unpublished.
· 10 months ago

I have used the VBA code1 which works great. It moves the row which contains a specific text as it should from sheet1 to sheet2. How do I enable it to additionally move a row from sheet2 to sheet3 when required also. I naively tried to put this code into a different module with the sheet names changed but this just brings back a debug error.

• To post as a guest, your comment is unpublished.
· 10 months ago
Hi Kieran Rao,
Your operation is correct. Just insert a new Module, copy the code into it and change the sheet names and value(if the value change).
What kind of error did you get?

• To post as a guest, your comment is unpublished.
· 10 months ago
Hey! I copied the code from Liam W and Edwin, but I want it so that when I update the drop down status/data on the Master Sheet and change it from LIVE to ENDED, it removes itself from the LIVE Sheet and is now on the ENDED sheet, but all stays on the Master sheet. Is that possible?

Additionally, if I add new content on the Master Sheet, is there a way for it to autorun, loop, etc. and send the updates to LIVE and/or ENDED? Or do you have to keep running the Macro anytime there is a new information on the Master Sheet?
• To post as a guest, your comment is unpublished.
· 10 months ago
Hi Miranda,
The code works well in my case. After running the code, the entire row will be moved to the specified worksheet.
Please don't forget to change the "C1:C" in the line "" to the column that contains the values you will move entire row based on.
View Code
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Updated by Extendoffice 20210319 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.
· 10 months ago
Thanks for that. For some reason, my ENDED page keeps starting on line 13. I changed the code slightly so that it doesn't delete but copies the row over from the main worksheet to the ENDED worksheet, but it keeps starting on line 13. Any chance you know why that might be, and/or what do to to fix it?

Thanks!
• To post as a guest, your comment is unpublished.
· 10 months ago
I wanted to move the row when certain cells are filled, regardless of what text they are as long as they are have value. In my case if columns G to L have values, this marks that all steps have been completed and I want to move it to the other worksheet automatically, without having to press F5 or manually click run. Is this possible?
• To post as a guest, your comment is unpublished.
· 11 months ago
Hello, Thank you for this wonderful Macro. May I ask, what if I would also like to move "No" on another sheet?
• To post as a guest, your comment is unpublished.
· 11 months ago
Hi Edwin,
This question had been asked by LiamW 2 years ago: 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"?
Please try the below VBA and change the values and worksheets based on your needs.
Sub MoveRowBasedOnCellValue() 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.
· 1 years ago
I've gotten my code to work successfully when transferring to another worksheet, however it is pasting over the existing information within that workbook instead of adding to the next available row.. I have tried to modify, but I am extremely green when it comes to VBA codes.

Sub MoveResolvedDelinquency()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("January 2021").UsedRange.Rows.Count
J = Worksheets("Resolved Delinquency").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Resolved Delinquency").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("January 2021").Range("I1:I" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Current" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Resolved Delinquency").Range("A" & LrowCompleted + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Current" 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.
· 11 months ago
Hi,
The copied values won't overwrite the existing information in the destination worksheet. Which Excel version are you using?
• To post as a guest, your comment is unpublished.
· 11 months ago
Hi Crystal -
think it's because I have to run it for it to move, so it's just overriding the entries that are already made?
• To post as a guest, your comment is unpublished.
· 1 years ago
I have seen several people ask about copying the data without duplicating it, and I have yet to find where this was answered. Does anyone have the answer to this question? Thank you!
• To post as a guest, your comment is unpublished.
· 1 years ago
I keep getting a Run-Time error '9' subscript out of range, and then when I hit debug, it highlights this line:

I = Worksheets("Sheet1").UsedRange.Rows.Count - I have replaced Sheet1 with the title of the sheet, Current Clients

Any help would be greatly appreciated!

• To post as a guest, your comment is unpublished.
· 1 years ago
Hi,
As the VBA code shown in the post, there are two "Sheet1" in the code. You need to replace both of them with the title of the sheet.
If you only replace one of them, this kind of error will pop up.
• To post as a guest, your comment is unpublished.
· 1 years ago
Can the VBA Code 2 be used in such a way as to overwrite the existing previous data in Sheet 2 so that if sheet 1 is modified the new application of the macro will overwrite the old Sheet2. Also can this line be modified to be a reference to a cell "If CStr(xRg(K).Value) = "Done" Then" so that you can type in what you want to move, other than "Done", and the macro uses it. For example I may want to move data based on "Tax" and then on "Price" later.

Thank you for these helpful instructions.
• To post as a guest, your comment is unpublished.
· 7 months ago
I need this too.:)
• To post as a guest, your comment is unpublished.
· 1 years ago

Frank

My current macro:
Private Sub CommandButton1_Click()

Application.Interactive = False

Dim Cl As Range
Dim Dic As Object

Set Dic = CreateObject("scripting.dictionary")
With Sheets("Shipment")
For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
Dic.Item(Cl.Value) = Cl.Offset(, 1).Resize(, 5)
Next Cl
End With
With Sheets("Master")
For Each Cl In .Range("O2", .Range("O" & Rows.Count).End(xlUp))
If IsEmpty(Cl.Offset(, 2).Value) Then
Cl.Offset(, 2).Resize(, 5) = Dic.Item(Cl.Value)
End If
Next Cl
End With

Sheets("Shipment").Range("A2:A100").ClearContents

Sheet4.Activate

Application.Interactive = True

End Sub
• To post as a guest, your comment is unpublished.
· 1 years ago
I am using the first VBA code. Essentially I have a column that I change to completed then I run the macros and this information moves to the completed page. It was working perfectly however it is not anymore. Eventually when i would run the macros the "completed"data started showing up extremely far down in the worksheet.I will note that the information on both worksheets is in a table. I figured out how to clear out the table and run the macros and have it show up right under the last moved data. BUT then it was not in the table! If I resize the table to include the data the next time I run the macros this new data goes directly under the table... so if I choose my table to end at row 500 my new data starts in row 501. I need to be able to move my data from one worksheet to another, have it stay in the table and not have large gaps in between the data(blank rows).. I hope this makes sense
• To post as a guest, your comment is unpublished.
· 6 months ago
Lynn, I am having the same issue now. Have you by chance found a resolution yet?
• To post as a guest, your comment is unpublished.
· 1 years ago
Is there a way to modify the code so that is doesn't duplicate already copied data?
• To post as a guest, your comment is unpublished.
· 1 years ago
This is very useful script. Thank you very much. However, I need to move the line in sheet 1 to sheet 2 only if 2 different cell's criteria are met such as cell b and cell h both contain the world YES. Is this possible?
• To post as a guest, your comment is unpublished.
· 1 years ago
Hi, thanks for everything! My code is pasting my rows at the bottom of my table... help please.

Private Sub CommandButton1_Click()
'Updated by Extendoffice 2017/11/10
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim M As Long
Dim K As Long
I = Worksheets("June").UsedRange.Rows.Count
M = Worksheets("July").UsedRange.Rows.Count
If M = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("July").UsedRange) = 0 Then M = 0
End If
Set xRg = Worksheets("June").Range("J3:J" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Part or Material On Order" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("July").Range("A" & M + 1)
M = M + 1
End If
Next
Application.ScreenUpdating = True
End Sub
• To post as a guest, your comment is unpublished.
· 1 years ago
Hi Jeremy,
This tutorial is talking about how to move a row to the bottom based on cell value. Maybe you can find the answer from it. Thank you!
https://www.extendoffice.com/documents/excel/3725-excel-move-row-to-bottom.html
• To post as a guest, your comment is unpublished.
· 1 years ago
This is a really useuful resource and the code Crystal posted about automatically moving a row to another sheet based on a selection works perfectly. The problem I have is that I am moving rows from one Row (based on the selection of 'Yes' in Column O). To another sheet. But both source and destination sheets are tables. This code works bu places teh row to the next free row outside of the table not inside it? Can you help? Thx.
• To post as a guest, your comment is unpublished.
· 1 years ago
Hi stusurrey,
Try the below VBA code. Hope I can help. Thank you.

Sub MoveRowBasedOnCellValue()
'Updated by Kutools for Excel 2020/5/22
Dim xRg As Range
Dim xCell, xCell1, xCell2 As Range
Dim xWs1, xWs2 As Worksheet
Dim I As Long
Dim J As Long
Dim K As Long
Dim xp, xNum1, xNum2 As Long
Dim xLO As ListObject
Set xWs1 = Worksheets("Sheet1")
Set xWs2 = Worksheets("Sheet2")
I = xWs1.UsedRange.Rows.Count
Set xLO = xWs2.ListObjects.Item(1)
Set xCell = xLO.Range
Set xCell1 = xCell.Item(1)
Set xCell2 = xCell.Item(xCell.Count)
J = xLO.Range.Rows.Count + xLO.Range.Item(1).Row - 1
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet1").Range("O1:O" & I)
On Error Resume Next
Application.ScreenUpdating = False
xp = 1
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Yes" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
J = J + 1
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Yes" Then
K = K - 1
End If
xp = xp + 1
End If
Next
Set xCell2 = xWs2.Cells(xCell2.Row + xp - 1, xCell2.Column) 'xCell2.Offset(xp, 0)
Application.ScreenUpdating = True
End Sub
• To post as a guest, your comment is unpublished.
· 1 years ago
Crystal,

Is there a way to modify the code so that is does not duplicate already copied data?
• To post as a guest, your comment is unpublished.
· 2 years ago
Good Day,

this code works and thanks a lot but i have 1 concern, when i delete some of the data in sheet 2, let say i deleted the info at the middle of sheet 2 then the info of that deleted part will be blank. when i run the program again it will only jump to the bottom part of the row. do you know how to use the offset? so that it will replace the blank part instead of pasting the data to the last row. thank in advance
• To post as a guest, your comment is unpublished.
· 2 years ago
Morning - I have a spreadsheet where if Yes is selected in column S in multiple sheets "January, February, March and so forth..." It will move the row details A-T to a separate sheet called Reversals automatically instead of hitting F5. All sheets including the Reversals sheet has the same header on row 1. Please assist with the VBA code. I have tried gathering different solutions based on the scenarios posted and I can't seem to get it to work seamlessly. Appreciate any guidance!
• To post as a guest, your comment is unpublished.
· 2 years ago
Is it possible to paste values only without formatting?

Thanks.
• To post as a guest, your comment is unpublished.
· 1 years ago
Hi Said,
Please try the below VBA. Hope I can help.

Sub MoveRowBasedOnCellValue()
'Updated by Extendoffice 2020/05/19
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.Copy
Worksheets("Sheet2").Range("A" & J + 1).PasteSpecial Paste:=xlPasteValues
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
• To post as a guest, your comment is unpublished.
· 2 years ago
Hi Crystal!!
Thanks for sharing this amazing code.
I have a request
can you change the copy paste to copy paste value, i have formulas on excel that will not be needed anymore once copied to another sheet. Thanks much
• To post as a guest, your comment is unpublished.
· 2 years ago
Does this not work if Column C is a drop down?
• To post as a guest, your comment is unpublished.
· 1 years ago
Hi Erica,
The code works for drop-down list option as well.
• To post as a guest, your comment is unpublished.
· 2 years ago
Kutools looks like a handy feature however, I don't know if it would work for what I'm trying to do.
I'm trying to use advanced INDEX and MATCH functions to pull entire rows out of one sheet and move to another automatically. For instance, if I were to have 3 sheets open, let's say I copy data from an Internet database, put it in Excel format, copy it to Sheet 2. Once I do that, I have Sheet 1 automatically pulling a limited amount of data from Sheet 2 to automatically populate Sheet 1 already using the INDEX and MATCH functions. That part I have down using this function: INDEX(Sheet2!A:Q,ROW()-2,(MATCH("TicketFromSiteLeaseCompanyName",Sheet2!\$A\$1:\$Q\$1,0))). This particular formula I don't completely understand what each piece is, but pulls data from Sheet 2 under the column title "TicketFromSiteLeaseCompanyName" to Sheet 1 at that particular cell where this formula goes.
What I'm trying to do is once Sheet 1 is done, use the INDEX and MATCH functions for Sheet 3 to take entire rows from Sheet 1 that the common factor would be an employees name and all the data that goes with it to Sheet 3. To get more specific, Sheet 3 would be renamed an employee's name and what I would like to do is set up a formula that would automatically populate Sheet 3 with just that employees information from Sheet 1 as the information is put into Sheet 1. By the way, there would be many many sheets after 3, each one having a different employees' name. I'm just using 3 sheets here total as a simple example.
I was also thinking of using a pivot table but I would have to build it every time and that's what I'm trying to avoid. I want to make a template one time then all I'd have to do is populate Sheet 2 and every other sheet in the database should take care of itself.

Any and all information on this would be extremely helpful Thank You.
• To post as a guest, your comment is unpublished.
· 2 years 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.
· 2 years 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.
· 2 years ago
Hi Rose,
You can reverse the sheet names in the code to shift the row back to the original worksheet, but the row can't be allocated back to th original row position.
Sorry for that.
• To post as a guest, your comment is unpublished.
· 2 years 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.
· 2 years 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.
· 2 years 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.
· 2 years ago
Hi Stephen,
• To post as a guest, your comment is unpublished.
· 4 months ago
hi there, has anyone figured out this problem?
• To post as a guest, your comment is unpublished.
· 2 years 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.
· 2 years 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

• To post as a guest, your comment is unpublished.
· 2 years ago
Hi Harry,
Try this VBA code. Hope I can help.

Sub Cheezy()
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 'Data
End If
Set xRg = Worksheets("Sheet1").Range("C1:C" & 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), "Done") > 0 Then
Range("A" & xRg(K).Row & ":" & "B" & xRg(K).Row).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

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

This is working perfectly for me but need it to be able to move 2 different criteria into 2 different sheets but only for a set range and not the entire row. Example : Move "Cleared" To Sheet 1, and "Failed" to Sheet 2.

• To post as a guest, your comment is unpublished.
· 2 years 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.
· 2 years 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.
· 2 years 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.
· 2 years ago
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.
· 2 years 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.
· 2 years 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