My sheet contains of cars that are placed at a certain location and need to be checked. This list is made twice a day and sometimes contains of 10 rows, sometimes 14, sometimes 12 etc. Now I would like to cut half of the rows and place it next to the other rows (in this case paste it in cell E). I would like to automate this process so in the VBA should be:
Count number of rows (X)
Cut the rows from X/2 to X
Paste the data in cell E1
I found this function which returns the middle cell. However, I would like to put this together in a sub.
Function Middle(r As Range) As Variant
Dim i As Long, j As Long
If r.Columns.Count > 1 Then
Middle = [#N/A]
Exit Function
End If
i = r.Row
j = r.Rows.Count
Middle = Cells(i + (j - 1) / 2, r.Column).Address
End Function
Sub cutting()
Range("Middle:C" & Range("A" & Rows.Count).End(xlUp).Row).Select
Selection.Cut
Range("E2").Select
ActiveSheet.Paste
Range("A1:C1").Select
Selection.Copy
Range("E1").Select
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Range("E8").Select
End Sub
Before
After
You don't need to select the data to work with it.
Try:
Sub Test()
Dim lLastRow As Long
Dim lCutRow As Long
With ThisWorkbook.Worksheets("Sheet1") 'Change Sheet1 to the name of your sheet.
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Find last row in column A.
If lLastRow > 1 Then
lCutRow = (lLastRow / 2) + 1
.Range(.Cells(lCutRow, 1), .Cells(lLastRow, 3)).Cut Destination:=.Cells(1, 5) 'Paste to row 1, column 5 (E1).
End If
End With
End Sub
Related
If cell in column I1-I14 is greater than cell in column J1-J14, I want to cut the entire row and paste values to the first empty row. (From row 16 and down.)
If cell i is greater than cell j, cut row and paste values to first empty row (row 16 in this example)
This code just pastes in the first row:
Sub Knapp6_Klicka()
Dim i As Long
Dim j As Long
j = 1
For i = 3 To 500
If Cells(i, 9).Value > Cells(i, 10).Value Then
Cells(i, 12).EntireRow.Cut Sheets("Blad1").Range("A" & j)
j = j + 1
End If
Next i
End Sub
I tried to combine the paste with two different solutions.
One like this, where I recorded a macro and went to the last cell, then up to the first empty cell:
Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
And one solution that I found on an Excel community:
Sub compareresult()
Dim row1 As Integer
Dim row2 As Integer
row2 = 1
For row1 = 8 To 500
If sheet1.Cells(row1, 11).value > sheet1.Cells(row1, 9).value Then
sheet1.Cells(row1, 1).EntireRow.Copy Sheets(11).Cells(row2, 1)
row2 = row2 + 1
End If
Next row1
End Sub
If cell in column I1-I14 is greater than cell in column J1-J14, i want to cut entire row and paste values to the first empty row. (From row 16 and down)
Here is a method which doesn't cut and paste in a loop. Since you are not deleting the row or "cutting and inserting" the row, here is a simple approach. The below code follows a basic logic
Logic
Loop and identify the range.
If found, then copy the range in 1 go.
Finally clear the range which was copied (if copied).
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rngToCopy As Range
Dim i As Long
'~~> Change this to relevant sheet
Set ws = Sheet1
With ws
'~~> Loop and identify the range
For i = 2 To 14
If .Range("I" & i).Value2 > .Range("J" & i).Value2 Then
If rngToCopy Is Nothing Then
Set rngToCopy = .Rows(i)
Else
Set rngToCopy = Union(rngToCopy, .Rows(i))
End If
End If
Next i
'~~> If found then copy and clear
If Not rngToCopy Is Nothing Then
rngToCopy.Copy .Rows(16)
rngToCopy.Clear
End If
End With
End Sub
EDIT:
To incorporate new edits
Works perfectly! Thanks! :) I failed to fully describe my problem.. What i also need is to paste it as special (only paste the value and not the formulas). Do you got any quick solution for that? – Johl 5 hours ago
Replace
rngToCopy.Copy .Rows(16)
to
rngToCopy.Copy
DoEvents
.Rows(16).PasteSpecial Paste:=xlPasteValues
Have a try with this.
It's based on the range you gave. Skipped over row 1 since you have headers in it.
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to
For i = 2 To 14 'Your range of rows to check
If ws.Range("I" & i) > ws.Range("J" & i) Then
ws.Range("I" & i).EntireRow.Cut ws.Range("A" & lRow) 'Cutting the whole row so you use column A to cut to
lRow = lRow + 1 'Move down 1 row for where to cut to
End If
Next i
Edit:
Because you only want the values to copy accross we can't use Cut and PasteSpecial xlValues so instead we will duplicate the value of the entire row to the new location, then clear the row (filling in for the cutting part). If clear is too much we can just ClearContents to remove the values in the cells instead of the formatting if that happens. Make sure to always save before running VBA code for the first time.
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to
For i = 2 To 14 'Your range of rows to check
If ws.Range("I" & i) > ws.Range("J" & i) Then
ws.Range("A" & lRow).EntireRow.Value = ws.Range("I" & i).EntireRow.Value 'Copying the values over
ws.Range("I" & i).EntireRow.Clear 'Clear the row
lRow = lRow + 1 'Move down 1 row for where to cut to
End If
Next i
Your code is doomed to failure because you do not take into consideration that you are cutting the found row. Think about what that means. Your row with the In,Out is row 15 and you wish to paste to row 16. If you cut row 5 (for example) then rows 15 and 16 will become rows 14 and 15. It also means that your next row (which you think will be row 6) will actually be what was row 7 before the cut.
I am trying to copy and paste data from one sheet to the next from a selected range entered by the user. TxtDateStart takes the start date, and TxtDateEnd takes the end date. Then it would copy and paste the data from the range of dates to a new sheet.
When I run the code in a form, it works but I rather have the form call the module. This is where I get the run-time error. I'm no expert in VBA, help would be appreciated.
The sheet where the data is is called Unit2Data, and the sheet i want to paste the data is Graphing Sheet.
The error occurs in this line
Sheets("Unit2Data").Range(Cells(i, 1), Cells(i, 73)).Select
Sub Unit2Data()
Dim lrow As Long, i As Long, x As Date, y As Date, erow As Long
x = TxtDateStart
y = TxtDateEnd
'Find the Last Row of Sheet1
lrow = Sheets("Unit2Data").Range("A" & Rows.Count).End(xlUp).Row
'start counting from row 3 to last row
For i = 4 To lrow
' Date value converted as numeric value by multiplying with number 1
If Cells(i, 1) * 1 >= x * 1 Then
If Cells(i, 1) * 1 <= y * 1 Then
'If above conditions matched then select the matched range/ entire column
Sheets("Unit2Data").Range(Cells(i, 1), Cells(i, 73)).Select
'copy the selected row
Selection.Copy
'to make sheet2 active where we want to paste the selected row
Sheets("Graphing Sheet").Activate
'to find the empty row from where the copied row of sheet1 to be pasted in sheet2
erow = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'to activate or select the empty row of sheet2
ActiveSheet.Cells(erow, 1).Select
'paste the copied data
ActiveSheet.Paste
'to deselect the copy and selected mode
Application.CutCopyMode = False
'for above the if we need 3 end if to close if conditions
End If
End If
'to activate sheet1 for searching the matched data
Sheets("Unit2Data").Activate
'continue for look until above matched found
Next i
End Sub
Date Data
01/01/2019 2
02/02/2019 3
First you should avoid using Select in VBA. There, almost always, are better ways to achieve whatever you are using Select for.
In your case, and regarding only the specific error/question raised, delete the error-causing line and the next line (Selection.Copy) and replace with this:
With Sheets("Unit2Data")
.Range(.Cells(i, 1), .Cells(i, 73)).Copy
End With
Rewriting your entire code to avoid using Select:
Sub Unit2Data()
Dim lrow As Long, i As Long, x As Date, y As Date, erow As Long
x = TxtDateStart
y = TxtDateEnd
With Sheets("Unit2Data")
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 4 To lrow
If .Cells(i, 1) * 1 >= x * 1 Then
If .Cells(i, 1) * 1 <= y * 1 Then
With Sheets("Graphing Sheet")
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
End With
.Range(.Cells(i, 1), .Cells(i, 73)).Copy _
Destination:= Sheets("Graphing Sheet").Cells(erow, 1)
End If
End If
Next i
End With
End Sub
I am trying to copy certain column from one worksheet to another but when I apply my code, I get no errors but also no results. I get blank paper. I applied this methodolgy on copying a certain row and it was copied to another worksheet perfectly.
This is regarding the successful attempt to copy row.
The code works just fine:
Sub skdks()
Dim OSheet As Variant
Dim NSheet As Variant
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Tabelle3" 'Old Sheet Name
NSheet = "Tabelle5" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).row
End If
'If cell has "certain # then..."
If Cells(i, 1).Value = Cells(13, 2).Value Then
Cells(i, 1).EntireRow.Copy
Sheets(NSheet).Cells(NSLRow + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next i
End Sub
This little piece of code is the failed attempt to copy column to another worksheet.
Sub trial()
Dim OSheet As Variant
Dim NSheet As Variant
Dim j As Integer
Dim LColumn As Integer
Dim NSLColumn As Integer
OSheet = "Tabelle2" 'Old Sheet Name
NSheet = "Tabelle5" 'New Sheet Name
LColumn = Sheets(OSheet).Cells(1, Columns.Count).End(xlToLeft).Column 'Last Column in Old Sheet
Sheets(OSheet).Activate
For j = 2 To LColumn
'Finds last column in the New Sheet
If Sheets(NSheet).Cells(1, 2) = "" Then
NSLColumn = 1
Else
NSLColumn = Sheets(NSheet).Cells(1, Columns.Count).End(xlToLeft).Column
End If
'If cell has "certain # then..."
If Cells(2, j) = Cells(13, 2) Then
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Cells(2, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next j
End Sub
....
'If cell has "certain # then..."
If Cells(2, j) = Cells(13, 2) Then
debug.Print Cells(2, j).Address; " = "; Cells(13, 2).Address; " ---- COPY"
debug.print Cells(2, j).EntireColumn.address; Cells(2, j).EntireColumn.cells.count
debug.Print Sheets(NSheet).Cells(2, 2).Address
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Cells(2, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
....
With the line If Cells(2, j) = Cells(13, 2) Then you compare the different cells from row 2 (B2, C2, D2, ...) with the value of cell "B13". If the value is the same you copy this column to the new worksheet.
Is there any equal value in your data? If yes you should get an error message with your code.
You try to copy the values of an entire column to the range starting with "B2". Of cause there is not enough space for this.
=> Either you reduce the source range or you start the destination range on row 1!
To add to the paste destination size, if you really want to paste the entire column, you either need to start at the beginning of the column or choose the entire column. Also, I think you want to make the paste column increase with your NSLColumn
If Cells(2, j) = Cells(13, 2) Then
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Columns(NSLColumn + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
My code is supposed to select all of the items in A-H from the top of the sheet to the bottom most row containing text in the J column. However, now all it does is select the top row. This code has worked fine elsewhere for other purposes, but when I run it here it only selects the top row.
Here is the code and what it currently does. The commented out bit does the same when it is ran in the place of the other finalrow =statement.
Option Explicit
Sub FindRow()
Dim reportsheet As Worksheet
Dim finalrow As Integer
Set reportsheet = Sheet29
Sheet29.Activate
'finalrow = Cells(Rows.Count, 10).End(xlUp).Row
finalrow = Range("J1048576").End(xlUp).Row
If Not IsEmpty(Sheet29.Range("B2").Value) Then
Range(Cells(1, 1), Cells(finalrow, 8)).Select
End If
End Sub
This is the excerpt of code with a row counter that works.
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
''loop through the rows to find the matching records
For i = 1 To finalrow
If Cells(i, 1) = item_code Then ''if the name in H1 matches the search name then
Range(Cells(i, 1), Cells(i, 9)).Copy ''copy columns 1 to 9 (A to I)
reportsheet.Select ''go to the report sheet
Range("A200").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False ''find the first blank and paste info there
datasheet.Select ''go back to the data sheet and continue searching
End If
Next i
You can try this:
Option Explicit
Sub FindRow()
' always use Longs over Integers
Dim finalrow As Long: finalrow = 1
' you might not need this line tbh
Sheet29.Activate
With Sheet29
' custom find last row
Do While True
finalrow = finalrow + 1
If Len(CStr(.Range("J" & finalrow).Value)) = 0 Then Exit Do
Loop
' Len() is sometimes better then IsEmpty()
If Len(CStr(.Range("B2").Value)) > 0 Then
.Range(.Cells(1, 1), .Cells((finalrow - 1), 8)).Select
End If
End With
End Sub
I have created the following macro
I have data going all the way to row 3710 in the master data sheet - and I do not know how to force this macro to loop and include all the data
Sub Macro3()
'
' Macro3 Macro
'
'
Range("A1:A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1:B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Sheet1").Select
Range("A3:A4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("A2:B2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
You can do this with a for loop. Also Copy/Paste is something we generally shy away from in VBA as well as .SELECT and .ACtivate. Those are functions that a human performs, but the computer can just set cells equal to other cell's values like:
Sheets("Sheet1").Cells(1, 1).value = Sheets("Sheet2").Cells(1,1).value
Which says Cell "A1" in Sheet1 should be set to whatever the value is in Sheet2 Cell "A1".
Changing things around, implementing a loop to perform your transpose, and using some quick linear regression formula to determine which row to write to we get:
Sub wierdTranspose()
'Loop from row 1 to row 3710, but every other row
For i = 1 to 3710 Step 2
'Now we select from row i and row i + 1 (A1 and A2, then A3 and A4, etc)
'And we put that value in the row of sheet2 that corresponds to (.5*i)+.5
' So if we are picking up from Rows 7 and 8, "i" will be 7 and (.5*i)+.5 will be row 4 that we paste to
' Then the next iteration will be row 9 and 10, so "i" will be 9 and (.5*i)+.5 will be row 5 that we paste to
' and on and on until we hit 3709 and 3710...
Sheets("Sheet2").Cells((.5*i)+.5, 1).value = Sheets("Sheet1").Cells(i, 1).value
Sheets("Sheet2").Cells((.5*i)+.5, 2).value = Sheets("Sheet1").Cells(i+1, 1).value
Next i
End Sub
Bulk data is best transferred via VBA arrays, with no copy/paste required.
Something like this:
Sub SplitColumn()
Dim A As Variant, B As Variant
Dim i As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
With ws1
A = .Range(.Cells(1, 1), .Cells(3710, 1))
End With
ReDim B(1 To 1855, 1 To 2)
For i = 1 To 1855
B(i, 1) = A(2 * i - 1, 1)
B(i, 2) = A(2 * i, 1)
Next i
With ws2
.Range(.Cells(1, 1), .Cells(1855, 2)).Value = B
End With
End Sub