How to select and cut an entire row from sheet1 and paste it in sheet2 - excel

Simple table in sheet1 with data in cells(A2:C4), column D is empty. I want to select the entire row, cut and paste it in sheet2 when a time is added in colum D.
When I clicked on the logout button, It will add a time punch in column D.
I want that entire row to be selected and then cut and paste in sheet2.
I want also to arrange the remaining entry to move up so that there's no spaces between.
Screenshot
Dim CM As Boolean
Private Sub cmdMove_Click()
Dim myLog As Worksheet
Dim myLogSheet As Range
Dim i As Long: i = 1
Set myLog = Sheets("Sheet1")
Set myLogSheet = myLog.Range("B:B").Find(txtID.Value, , , xlWhole)
'Dim LastRow As Long
'LastRow = Sheets("Sheet2").Range("A65536").End(xlUp).Row + 1
If Not myLogSheet Is Nothing Then
myLogSheet.Offset(0, 2) = Format(Now, "hh:mm:ss")
With ActiveSheet
For n = nLastRow To nFirstRow Step -1
If .Cells(n, "D") = "" Then
.Cells(n, "D").EntireRow.Cut Sheet2.Cells(i, "A")
.Cells(n, "D").EntireRow.Delete '~~> if you want to delete
i = i + 1
End If
Next
End With
Else
txtName.Value = "NO RECORD"
End If
End Sub

You need to remove your loop, and just use the row you found using the Find:
Dim CM As Boolean
Private Sub cmdMove_Click()
Dim myLog As Worksheet
Dim myLogSheet As Range
Dim myLogSheetRow As Long
Dim i As Long
i = 1
'Probably you want:
i = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row + 1
Set myLog = Sheets("Sheet1")
Set myLogSheet = myLog.Range("B:B").Find(txtID.Value, , , xlWhole)
If Not myLogSheet Is Nothing Then
myLogSheetRow = myLogSheet.Row ' So we can delete the row later
myLogSheet.Offset(0, 2) = Format(Now, "hh:mm:ss")
myLogSheet.EntireRow.Cut Sheet2.Cells(i, "A")
myLog.Rows(myLogSheetRow).Delete
Else
txtName.Value = "NO RECORD"
End If
End Sub
Note that Excel exhibits very odd behaviour when deleting the row after the Cut. Using a statement of myLogSheet.EntireRow.Delete after the Cut causes Excel to delete the row in Sheet1 based on the new location of the cell in Sheet2. This is why a variable needs to be created to refer to the row prior to the Cut, so that it can be used in the Delete after the Cut.

Related

Loop through and copy paste values without repetition if conditions are met

Im trying to create a table that pulls data from my raw data if certain conditions are met. The code I currently have does not seem to be working.
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long
Dim tableA As ListObject
Set tableA = Worksheets(Sheet7).ListObject(Preventable)
Set datasheet = Worksheets(Sheet7)
Set datasheet2 = Worksheets("Data")
With datasheet2
nr = Cells(Rows.Count, 1).End(x1up).Row
For r = 1 To nr
If Cells(r, 17) = "Y" Then
Cells(r, 16).Copy Destination:=Sheets("Sheet7").Range("B4")
End If
Next
End With
End Sub
Basically I have several worksheets and need to pull data from one of them to add to this table in another worksheet. My condition is if the Column in the raw data worksheet contains "Y", then pull cell values into the table of the other worksheet. An image below is an example of the data I want to copy and paste over:
As you can see, they are string values separated by "," and can contain duplicates.
I only want to add just the unique entries into the new table; with no repetition of cells. Anyway I could modify this code to suit those conditions?
You could try something like this:
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long, i As Long, nr As Long
Dim tableStartingRow As Long, currenttableitem As Long
Dim stringvalues As Variant
Dim stringseparator As String
Dim valueexists As Boolean
tableStartingRow = 4
stringseparator = ","
Set datasheet = Worksheets("Sheet7")
Set datasheet2 = Worksheets("Data")
With datasheet
currenttableitem = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
With datasheet2
nr = .Cells(.Rows.Count, 16).End(xlUp).Row
For r = 1 To nr
If .Cells(r, 17) = "Y" Then
If InStr(.Cells(r, 16), stringseparator) > 0 Then 'If value contains comma
stringvalues = Split(.Cells(r, 16), stringseparator)
For i = LBound(stringvalues) To UBound(stringvalues)
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = Trim(stringvalues(i)) Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = Trim(stringvalues(i))
End If
Next i
Else
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = .Cells(r, 16).Value Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = .Cells(r, 16).Value
End If
End If
End If
Next
End With
End Sub
This code will check each value of the cells and will split the contents by ",". Then compare with the content of the table to see if this value is already in there. In case it is not, it will be added, otherwise omitted.
Also, I notice the use of the Cells inside of a With statement. That was making a reference to the active worksheet. To make reference to the item in the With statement, you need to use .Cells
I hope this will help.

How do I Cut a range from one worksheet to Paste to a second and make sure future lines go to the next blank row?

Two questions:
1) I have a spreadsheet (TC) that has data on one page that will be updated daily. There are 28 columns. Essentially I am looking to have the line (row) data cut and paste into a second spreadsheet (Archive) when Col. 28 has a value entered in it. I have the base coding but for some reason it causes Excel to be non-responsive.
I think it might be because the coding goes cell by cell rather than row by row. Can anyone point me in the right direction? (Again, keep in mind, this is a snippet of the coding - I have each Cut and Paste up to Column 28.)
2) The second part of my question is: Will what I have written make sure that when the Command Button is pressed next time, the data will cut and paste to the next blank line. Thank you!
Private Sub CommandButton1_Click()
a = Worksheets("TC").Cells(Rows.Count, 2).End(xlUp).Row
'Dim rng As Range
'Set rng = Worksheets("Archived").Range("A1")
b = 1
For i = 2 To a
If Worksheets(“TC”).Cells(i, 28).Value <> "" Then
'Change # to be the number column of Pt Name
Worksheets(“TC”).Cells(i, 1).Cut
'Change ,# to be the number column of where you want it pasted.
Worksheets(“TC”).Paste Destination:=Worksheets(“Archive”).Cells(b + 1, 1)
'Change ,# to be the number column of SOC
Worksheets(“TC”).Cells(i, 2).Cut
'Change ,# to be the number column of where you want it pasted.
Worksheets(“TC”).Paste Destination:=Worksheets(“Archive”).Cells(b + 1, 2)
b = b + 1
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets(“TC”).Cells(1, 1).Select
End Sub
You can do something like this:
Private Sub CommandButton1_Click()
Dim i as long, b As Long, shtTC as worksheet, shtArch as worksheet
Set shtTC = Worksheets("TC")
Set shtArch = Worksheets("Archive")
'find the first empty row
b = shtArch.Cells(Rows.Count, 2).End(xlUp).Row + 1 'pick a column which will always be populated
For i = 2 To shtTC.Cells(Rows.Count, 2).End(xlUp).Row
If shtTC.Cells(i, 28).Value <> "" Then
'cut the row
shtTc.Cells(i, 1).Resize(1, 28).Cut shtArch.Cells(b, 1)
b = b + 1
End If
Next
Application.CutCopyMode = False
shtTC.Cells(1, 1).Select
End Sub
Here's an example of how to create the kind of copy results you're looking for. Notice that, unless you specifically want to copy/paste all of the formatting with the data, you don't need to use copy/paste. You can perform the copy by assigning the values of the ranges.
Option Explicit
Private Sub CommandButton1_Click()
CopyData ThisWorkbook.Sheets("TC"), ThisWorkbook.Sheets("Archived")
End Sub
Public Sub CopyData(ByRef source As Worksheet, _
ByRef dest As Worksheet, _
Optional ByVal deleteSource As Boolean = False)
'--- calculate and create the source data range
Const TOTAL_COLUMNS As Long = 1
Dim srcRange As Range
Dim lastRow As Long
With source
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set srcRange = .Range("A1").Resize(lastRow, TOTAL_COLUMNS)
End With
'--- determine where the data should go
Dim destRange As Range
With dest
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lastRow > 1 Then lastRow = lastRow + 1
Set destRange = .Cells(lastRow, 1)
Set destRange = destRange.Resize(srcRange.Rows.Count, TOTAL_COLUMNS)
End With
'--- now copy the data
destRange.Value = srcRange.Value
'--- optionally delete the source data
If deleteSource Then
srcRange.Clear
End If
End Sub

VBA TextBox fill values in colunm to specific range

My workbook has two sheets: one "Data" and one "Kiert". I solved to copy rows by specific attributes from "data" to "Kiert" with UserForm, but I added ti user form four textboxes (TextBox1, TextBox2 etc.) and I want to fill the database with constant values added in textbox with one command button in blank colums after pasted data.
I have additional textbox5, which indicates if the copy was succefull ("SIKERES"), this part works fine...
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim lastRow As Long
Dim srcRange As Range, fillRange As Range
Set a = TextBox5
Set d = TextBox1
Set ws = Sheets("Data")
Set Drng = ws.Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy
Sheets("Kiert").Range("A1000000").End(xlUp).Offset(1, 0)
Range("F:F" & lastRow).Formula = TextBox1.Value
If c.Value = ListBox1.Value Then
a.Value = "SIKERES"
End If
End If
Next c
End Sub
I insert here an example:
My main problem is I cannot describe a correct range and description of textboxes, and I don't know where I can put it in my code to run it properly.
I tried this:
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy Sheets("Summary").Range("A1048576").End(xlUp).Offset(1, 0)
Sheets("Kiert").Range("A:A" & lasrRow).Value = TextBox1.Text
If c.Value = ListBox1.Value Then
A.Value = "SIKERES"
End If
End If
Next c
...but its out of range.
It's not very clear what you are trying to do, but the code below will help you paste the values of your textboxes to the relevant column:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim NextFreeRow As Long
Dim srcRange As Range, fillRange As Range
Set Drng = Sheets("Data").Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells 'loop through Column A on Sheet Data
If c = ListBox1.Value Then 'If the cells in Column A Sheet Data matches the selection on your Listbox1 then
NextFreeRow = Sheets("Kiert").Cells(Rows.Count, "A").End(xlUp).Row + 1 'Check the next free row on Sheet Kiert
c.EntireRow.Copy Desination:=Sheets("Kiert").Range("A" & NextFreeRow) 'Paste the entire row from Sheet Data to Sheet Kiert
Range("F" & NextFreeRow).Value = TextBox1.Text 'Copy the contents of TextBox1 to column F
'Add more lines like the one above to copy the values from your Textboxes to the relevant column
TextBox5.Text = "SIKERES"
End If
Next c
End Sub

Editing Excel Macro VBA to have it fill in Column C and right, instead of Column A

I am currently using the Macro below for excel to move data from one one sheet to another. It is set up to fill from Row 2 down, as long as the rows are empty. I not want to have it already contain data in Columns 2 & 3. I have tried a number of things and am not having a lot of luck. I am new to this and "fixing" someone else's macro.
Sub MergeSheets()
Sheets("New").Activate
LastRowNew = Application.WorksheetFunction.CountA(Columns(1))
For i = 2 To LastRowNew
OrderNumber = Cells(i, 3)
Sheets("PRIOrders").Activate
LastRowPRI = Application.WorksheetFunction.CountA(Columns(1))
For j = 2 To LastRowPRI
If Cells(j, 3) = OrderNumber Then
Exit For
ElseIf j = LastRowPRI Then
Sheets("New").Rows(i).Copy Destination:=Sheets("PRIOrders").Rows(LastRowPRI + 1)
Sheets("PRIOrders").Rows(2).Copy
Sheets("PRIOrders").PasteSpecial xlPasteFormats
End If
Next
Sheets("New").Activate
Next
Sub MergeSheets()
Dim shtNew As Worksheet, shtOrders As Worksheet
Dim rngOrder As Range, rngNewOrders As Range
Dim f As Range, lastRow As Long
Set shtNew = ActiveWorkbook.Sheets("New")
Set rngNewOrders = shtNew.Range(shtNew.Range("C2"), _
shtNew.Cells(Rows.Count, 3).End(xlUp))
Set shtOrders = ActiveWorkbook.Sheets("PRIOrders")
For Each rngOrder In rngNewOrders.Cells
Set f = shtOrders.Columns(3).Find(Trim(rngOrder.Value), , xlValues, xlWhole)
If f Is Nothing Then
'find the last occupied row in Col B or C
lastRow = Application.Max(shtOrders.Cells(Rows.Count, 2).End(xlUp).Row, _
shtOrders.Cells(Rows.Count, 3).End(xlUp).Row)
rngOrder.EntireRow.Copy shtOrders.Cells(lastRow + 1, 1)
End If
Next rngOrder
End Sub

Copy Paste VBA Code Has Blank Rows

The below code searches, copies & pastes the found data into another worksheet. However, there are blanks when this is done in the pasted worksheet. Eg: Found "To Be Copied" in Cell A1 and copied the entire row to the specified worksheet. Found "To Be Copied" in A4 and copied the entire row to the specified worksheet. However, there are two blank rows in the pasted sheet between A1 and A4. Thanks for your help.
Sub Deleting()
Application.ScreenUpdating = False
Dim wsh As Worksheet, i As Long, Endr As Long, x1 As Worksheet, p As Long
Set wsh = ActiveSheet
Worksheets.Add(Before:=Worksheets("Original Sheet")).Name = "Skipped"
Set x1 = Worksheets("Skipped")
Worksheets("ABC").Activate
i = 2
Endr = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
While i <= Endr
If Cells(i, "A") = "To Be Copied" Then
wsh.Rows(i).Copy
x1.Rows(i).PasteSpecial
p = p + 1
Endr = Endr + 1
End If
i = i + 1
Wend
End Sub
You need two counters: i for the source rows, j for the destination rows. You only increment j when a row is copied.
Your existing code needs either
A separate counter for the written row position (Cutter's point), or
Pasting to the last used row of "Skipped" using xlUp to find the last used cell
But better still would be copying the rows in a single shot using AutoFilter. Something like below
Sub Quicker()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Application.ScreenUpdating = False
Set ws1 = Sheets("ABC")
Set ws2 = Worksheets.Add(Before:=Worksheets("Original Sheet"))
'in case Skipped exists
On Error Resume Next
ws2.Name = "Skipped"
On Error GoTo 0
ws1.AutoFilterMode = False
Set rng1 = ws1.Range(ws1.[a1], ws1.Cells(Rows.Count, "A").End(xlUp))
rng1.AutoFilter 1, "To Be Copied"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then
Set rng1 = rng1.Offset(1, 0).Resize(rng1.Rows.Count - 1)
rng1.EntireRow.Copy ws2.[a1]
End If
ws1.AutoFilterMode = False
MsgBox "Sheet " & ws2.Name & " updated"
End Sub

Resources