Sposta l'intera riga su un altro foglio in base al valore della cella con codice VBA
Come mostrato nell'immagine sottostante, è necessario spostare l'intera riga da Sheet1 a Sheet2 se esiste una parola specifica "Fatto" nella colonna C. È possibile provare il seguente codice VBA.
1. Stampa altro+ F11 tasti contemporaneamente per aprire il file Microsoft Visual Basic, Applications Edition finestra.
2. Nella finestra Microsoft Visual Basic, Applications Edition, fare clic su inserire > Modulo. Quindi copia e incolla il codice VBA sottostante nella finestra.
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
Note:: Nel codice, Sheet1 è il foglio di lavoro che contiene la riga che si desidera spostare. E Sheet2 è il foglio di lavoro di destinazione in cui individuare la riga. "C: C"È la colonna che contiene il determinato valore e la parola"Fatto"È il valore certo su cui sposterai la riga. Si prega di modificarli in base alle proprie esigenze.
3. premi il F5 chiave per eseguire il codice, quindi la riga che soddisfa i criteri in Sheet1 verrà spostata immediatamente in Sheet2.
Note:: Il codice VBA sopra cancellerà le righe dai dati originali dopo lo spostamento in un foglio di lavoro specificato. Se desideri copiare solo le righe in base al valore della cella invece di eliminarle. Si prega di applicare il codice VBA di seguito 2.
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
Sposta l'intera riga su un altro foglio in base al valore della cella con Kutools per Excel
Se sei un principiante nel codice VBA. Qui presento il Seleziona celle specifiche utilità di Kutools for Excel. Con questa utility, puoi selezionare facilmente tutte le righe in base a un determinato valore di cella o a diversi valori di cella in un foglio di lavoro e copiare le righe selezionate nel foglio di lavoro di destinazione di cui hai bisogno. Si prega di fare quanto segue.
1. Selezionare l'elenco di colonne contenente il valore della cella su cui spostare le righe in base, quindi fare clic su Kutools > Seleziona > Seleziona celle specifiche. Vedi screenshot:
2. In apertura Seleziona celle specifiche finestra di dialogo, scegliere Intera riga nello Tipo di selezione sezione, selezionare Equivale nello Tipo specifico dall'elenco a discesa, immettere il valore della cella nella casella di testo e quindi fare clic su OK pulsante.
Un altro Seleziona celle specifiche la finestra di dialogo si apre per mostrare il numero di righe selezionate e, nel frattempo, tutte le righe contengono il valore specificato nella colonna selezionata sono state selezionate. Vedi screenshot:
3. premi il Ctrl + C tasti per copiare le righe selezionate, quindi incollarle nel foglio di lavoro di destinazione necessario.
Note:: Se desideri spostare le righe in un altro foglio di lavoro in base a due diversi valori di cella. Ad esempio, sposta le righe in base ai valori delle celle "Fine" o "Elaborazione", puoi abilitare il Or condizione nel Seleziona celle specifiche finestra di dialogo come mostrato nell'immagine sottostante:
Se desideri avere una prova gratuita (30 giorni) di questa utility, fare clic per scaricarlo, quindi andare ad applicare l'operazione secondo i passaggi precedenti.
I migliori strumenti per la produttività in ufficio
Kutools per Excel risolve la maggior parte dei tuoi problemi e aumenta la tua produttività dell'80%
Riutilizzo: Inserisci rapidamente formule complesse, grafici e tutto ciò che hai usato prima; Crittografa celle con password; Crea mailing list e invia email ...
Bar Super Formula (modifica facilmente più righe di testo e formula); Layout di lettura (leggi e modifica facilmente un gran numero di celle); Incolla su intervallo filtrato...
Unisci celle / righe / colonne senza perdere dati; Contenuto delle celle divise; Combina righe / colonne duplicate... Impedisci celle duplicate; Confronta intervalli...
Seleziona Duplica o Unico Righe; Seleziona Righe vuote (tutte le celle sono vuote); Super Find e Fuzzy Find in molte cartelle di lavoro; Selezione casuale ...
Copia esatta Più celle senza modificare il riferimento della formula; Riferimenti di creazione automatica a più fogli; Inserisci punti elenco, Caselle di controllo e altro ...
Estrai testo, Aggiungi testo, Rimuovi per posizione, Rimuovi spazio; Creare e stampare totali parziali di paging; Converti contenuto e commenti tra celle...
Super filtro (salva e applica schemi di filtri ad altri fogli); Ordinamento avanzato per mese / settimana / giorno, frequenza e altro; Filtro speciale in grassetto, corsivo ...
Combina cartelle di lavoro e fogli di lavoro; Unisci tabelle in base a colonne chiave; Suddividi i dati in più fogli; Conversione in batch xls, xlsx e PDF...
Più di 300 potenti funzionalità. Supporta Office / Excel 2007-2019 e 365. Supporta tutte le lingue. Facile distribuzione nella tua azienda o organizzazione. Funzionalità complete Prova gratuita di 30 giorni. Garanzia di rimborso di 60 giorni.
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
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
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
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.
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.
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
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") 'åÒíäå áÈÇÓ
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
ElseIf CStr(xRg(K).Value) = " Transportation, unloading and loading" Then 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
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 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'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.
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.
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?
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.
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.
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?
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.
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!
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.
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?
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
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?
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?
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
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
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!
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.
Hello. First and foremost, thank you for you continued efforts and hard work. This site is great. I am attempting to slightly modify the "move" script but am running into issues as my VB skills are not strong. One of the comments below is similar to what i'm trying to accomplish but different enough to still give me trouble. I'll try to explain as best as I can. I have two sheets. Master and Shipment. Master is a sheet of on hand inventory. Shipment is a temp sheet where a barcode scanner downloads unique serial numbers that also exist on the Master sheet (Column O on Master, Column A on Shipment). What I would like to do is after downloading the barcodes, execute the macro and if/when it matches, copy the matching row (Column A thru E) from Shipment and paste it to the matching row on Master (Beginning with Column Q thru U). Crystal helped another user about 2 years ago with something similar where the user was trying to match on a dynamic value rather than "Done". If you search this page for "CStr(yRg(M).Value)", you will find the post. I was able to use some of this to copy the data from Shipment to a new Sheet, but not able to copy it to my desired sheet nor the proper cell location. I currently have this working with a different approach but I feel the approach I am currently using is inefficient and takes quite a while. I'll paste the code below as it might help you understand better what I am attempting. Thank you in advance and for all your efforts in helping us in need.
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
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
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?
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
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
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.
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)
Debug.Print xCell2.Address xLO.Resize Range(xCell1.Address & ":" & xCell2.Address)
Application.ScreenUpdating = True
End Sub
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
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!
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
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
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.
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.
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?
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.
Thank you for your comment.
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.
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.
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
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
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.
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?
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?
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
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
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.
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.
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 ?
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?
