I made a model for our project managers to follow the economy in different projects.
A wish for the model was the option to add rows into the matrix I made without losing the formulas and subtotals within the scheme.
By copy-pasting and editing formulas from this site I made buttons throughout the matrix to add rows.
It is slow. Whenever they press one of my buttons it takes about 44 seconds for a new row to be added and the formulas etc. to be copy-pasted into the new row.
It looks like it is all the copy-paste steps that is the trouble.
Can I make this copy-paste-code faster?
I tried copying the range instead but I can't make that work, neither copying the entire row (it also pastes the button, which I would like it NOT to).
Sub Tilføj_række()
Dim b As Object, cs As Integer
Set b = ActiveSheet.Shapes(Application.Caller)
With b.TopLeftCell.EntireRow.Offset(1, 0)
.Insert
.Cells(1, 3).Copy .Cells(0, 3)
.Cells(1, 4).Copy .Cells(0, 4)
.Cells(1, 5).Copy .Cells(0, 5)
.Cells(1, 6).Copy .Cells(0, 6)
.Cells(1, 7).Copy .Cells(0, 7)
.Cells(1, 8).Copy .Cells(0, 8)
.Cells(1, 9).Copy .Cells(0, 9)
.Cells(1, 10).Copy .Cells(0, 10)
.Cells(1, 11).Copy .Cells(0, 11)
.Cells(1, 12).Copy .Cells(0, 12)
.Cells(1, 13).Copy .Cells(0, 13)
.Cells(1, 14).Copy .Cells(0, 14)
.Cells(1, 15).Copy .Cells(0, 15)
.Cells(1, 16).Copy .Cells(0, 16)
.Cells(1, 17).Copy .Cells(0, 17)
.Cells(1, 18).Copy .Cells(0, 18)
.Cells(1, 19).Copy .Cells(0, 19)
.Cells(1, 20).Copy .Cells(0, 20)
.Cells(1, 21).Copy .Cells(0, 21)
.Cells(1, 22).Copy .Cells(0, 22)
End With
End Sub
A piece of my matrix looks like this where the green buttons are the triggers for the code.
The bold rows contains sum-functions.
I hope you geniuses can help me once more.
Sometimes the answer is so simply and right in front of you, that you overlook it....
Almost right after I gave up and posted this, I found the answer myself, so if someone is ever in the same trouble as I was, the answer is:
Sub Tilføj_række()
Dim b As Object, cs As Integer
Set b = ActiveSheet.Shapes(Application.Caller)
With b.TopLeftCell.EntireRow.Offset(1, 0)
.EntireRow.Copy
.Insert
End With
End Sub
Related
Here is my code:
For j = 3 To 37 Step 2
If PaddleBDateInstalledTextBox.Value = Cells(j, 8).Value Then
Cells(j, 8).Copy
Range("D42").PasteSpecial Paste:=xlPasteValues
Range("D42").PasteSpecial Paste:=xlPasteFormats
Range("D42").PasteSpecial Paste:=xlPasteAllUsingSourceTheme '<--
cells background, etc.
Range("D42").NumberFormat = "MM/DD/YY"
Cells(j, 8).Clear
End If
Next
I have one cell where the format is a date and I am trying to copy it first and then paste it into another cell but my cell did not have the value pasted in it and the original cell; and the contents were not cleared.
I have another cell that has the format Today() and I want to just copy the value without the formula into another cell but i have failed as well.
The last cell that I want to copy has a formula of =($I$2-H2)+(G2-F2) and I have the same problem.
This code worked for me:
If 1 = Cells(1, 1).Value Then 'Assuming in Cell(1, 1) is the value 1
Cells(1, 1).Copy
Range("B1").PasteSpecial Paste:=xlPasteValues
Range("B1").PasteSpecial Paste:=xlPasteFormats
Range("B1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Range("B1").NumberFormat = "MM/DD/YY"
Cells(1, 1).Clear
End If
Maybe the Cells(j, 8).Value is your problem. What value does j have? If j is a variable your code should be right, but if you mean J as column name the code should be Range("J" & 8).Value or Cells(8, "J").Value instead of Cells(j, 8).Value
This question already has answers here:
Copy Paste Values only( xlPasteValues )
(7 answers)
Closed 4 years ago.
I have code that works perfectly except for I can not seem to paste only values of the copied cell. How would I tell this code to only paste values and not merely copy and paste the cell. I have tried Google, Stack etc with no luck every variation of paste special I try fails! Thanks!
Sheets("AAAA").Select
Dim LR As Long, i As Long
With Sheets("AAAA")
LR = .Range("H" & Rows.Count).End(xlUp).Row
For i = 2 To LR
With .Range("G" & i)
If .Cells.Value = "NO MATCH" Then
With Sheets("BBBB")
ActiveSheet.Cells(i, 1).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0)
ActiveSheet.Cells(i, 2).Copy .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0)
ActiveSheet.Cells(i, 3).Copy .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0)
ActiveSheet.Cells(i, 4).Copy .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
ActiveSheet.Cells(i, 5).Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0)
ActiveSheet.Cells(i, 7).Copy .Cells(.Rows.Count, "H").End(xlUp).Offset(1, 0)
ActiveSheet.Cells(i, 8).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
End If
End With
Next i
End With
Be careful with nested With statements. Maybe fully qualify the second sheet in the inner With.
That said, you can remove the copy altogether and swop it round into an assignment using .Text property of range (cell) to give value only e.g.
.Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0) = ActiveSheet.Cells(i, 1).Text
Better still use .Value2
.Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0) = ActiveSheet.Cells(i, 1).Value2
It preserves more formats and is more resilient.
This is part of my script, easy loop copying some rows from one sheet to another:
a = 3
With Sheets("ATD")
Do While .Range("A" & a) <> ""
If .Cells(a, 6).Value = "x" And .Cells(a, 8).Value = "y" Then
.Range(Cells(a, 1), Cells(a, 10)).Copy
Sheets("ART").Range("A" & Sheets("ART").Range("A" & Rows.Count).End(xlUp).row + 1).PasteSpecial xlPasteValues
End If
a = a + 1
Loop
End With
It fails almost every time on .Range(Cells(a, 1), Cells(a, 10)).Copy line (Run-time error '1004': Application-defined or object-defined error). When I add .Select command like this:
a = 3
With Sheets("ATD")
Do While .Range("A" & a) <> ""
If .Cells(a, 6).Value = "x" And .Cells(a, 8).Value = "y" Then
.Select
.Range(Cells(a, 1), Cells(a, 10)).Copy
Sheets("ART").Range("A" & Sheets("ART").Range("A" & Rows.Count).End(xlUp).row + 1).PasteSpecial xlPasteValues
End If
a = a + 1
Loop
End With
everything works fine.
I know I can change .Copy on something like
Sheets("ATD").Range(Cells(a, 1), Cells(a, 10)).Value = Sheets("ART").Range(Cells(b, 1), Cells(b, 10)).Value
but I have another question. If .Copy function require, that cells I want to copy are in currently selected sheet, or am I missing something here?
Can you try with:
.Range(.Cells(a, 1), .Cells(a, 10)).Copy
The points are really important, as they reference the current Cells with the Sheet Object set in the With Sheets("ATD") line.
I want to create a button that does autofills in multiple worksheets. But it seems I could only do autofill one sheet at a time... Here is the code:
Private Sub CommandButton1_Click()
Sheets("Sheet1").Range(Cells(1, 1), Cells(1, 1)).AutoFill Destination:=Sheets("Sheet1").Range(Cells(1, 1), Cells(2, 1))
Sheets("Sheet2").Range(Cells(1, 1), Cells(1, 1)).AutoFill Destination:=Sheets("Sheet2").Range(Cells(1, 1), Cells(2, 1))
End Sub
Simple at that. If I break it down into two different buttons, they work just fine. I've tried Worksheets().Activate, but it doesn't help. (most people don't recommend activate anyways) Also tried writing Sub but the same problem persist as "error 1004".
You've ran into a common coding error where the Range.Cells property inside the Range object do not have their parent explicitly defined.
Private Sub CommandButton1_Click()
With Sheets("Sheet1")
.Range(.Cells(1, 1), .Cells(1, 1)).AutoFill _
Destination:=.Range(.Cells(1, 1), .Cells(2, 1))
End With
With Sheets("Sheet2")
.Range(.Cells(1, 1), .Cells(1, 1)).AutoFill _
Destination:=.Range(.Cells(1, 1), .Cells(2, 1))
End With
End Sub
Note .Range(.Cells(1, 1), .Cells(1, 1)) and not .Range(Cells(1, 1), Cells(1, 1)). Your original was trying to define a range containing the cells on another worksheet.
The With ... End With statement can make the assignment of the parent worksheet a lot easier and doesn't obfuscate what you are trying to accomplish.
It works when I added Activate:
Sheets("Sheet1").Activate 'added
Sheets("Sheet1").Range(Cells(1, 1), Cells(1, 1)).AutoFill _
Destination:=Sheets("Sheet1").Range(Cells(1, 1), Cells(2, 1))
Sheets("Sheet2").Activate 'added
Sheets("Sheet2").Range(Cells(1, 1), Cells(1, 1)).AutoFill _
Destination:=Sheets("Sheet2").Range(Cells(1, 1), Cells(2, 1))
I have some code to combine two rows into one based on a matching reference. There are 10 columns initially, which will become 20 columns, once the rows are combined.
The code works but is very slow. It's almost like it is looping every row in the sheet rather than just based on the "LastRow" variable. Is that the issue or is it something else?
If I turn off updates it is still slow. If I leave them on the screen just flashes forever until kill it in task manager.
Sub CombineRows()
'define variables
Dim RowNum As Long, LastRow As Long
Application.ScreenUpdating = False
'start below titles and make full selection of data
RowNum = 2
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A2", Cells(LastRow, 10)).Select
'For loop for all rows in selection with cells
For Each Row In Selection
With Cells
'if order number matches
If Cells(RowNum, 4) = Cells(RowNum + 1, 4) Then
'move attribute 2 up next to attribute 1 and delete empty line
Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 11)
Cells(RowNum + 1, 2).Copy Destination:=Cells(RowNum, 12)
Cells(RowNum + 1, 3).Copy Destination:=Cells(RowNum, 13)
Cells(RowNum + 1, 4).Copy Destination:=Cells(RowNum, 14)
Cells(RowNum + 1, 5).Copy Destination:=Cells(RowNum, 15)
Cells(RowNum + 1, 6).Copy Destination:=Cells(RowNum, 16)
Cells(RowNum + 1, 7).Copy Destination:=Cells(RowNum, 17)
Cells(RowNum + 1, 8).Copy Destination:=Cells(RowNum, 18)
Cells(RowNum + 1, 9).Copy Destination:=Cells(RowNum, 19)
Cells(RowNum + 1, 10).Copy Destination:=Cells(RowNum, 20)
Rows(RowNum + 1).EntireRow.Delete
End If
End With
'increase rownum for next test
RowNum = RowNum + 1
Next Row
'turn on screen updating
Application.ScreenUpdating = True
End Sub
I think what's taking it slow is the multiple copy and paste wherein you can just do it in one go. Also, If you are checking Column 4 only, then just loop there. Another important thing is you cannot delete the row after you copy it. The rows will move and then you will not get your expected results. Try to get those rows first and delete in one go after you finished the iteration.
Try something a bit cleaner and direct:
Edit1: After reviewing your code, it seems you are trying to combine duplicates in the same row.
Sub CombineRows()
Dim RowNum As Long, LastRow As Long
Dim c As Range, rngtodelete As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
RowNum = 2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For Each c In .Range("D2:D" & LastRow) 'Loop in D column only
If c.Value2 = c.Offset(1, 0).Value2 Then
'Cut and paste in one go
c.Offset(1, -3).Resize(, 10).Cut .Range("K" & RowNum)
'Mark the rows to delete
If rngtodelete Is Nothing Then
Set rngtodelete = c.Offset(1, 0).EntireRow
Else
Set rngtodelete = Union(rngtodelete, c.Offset(1, 0).EntireRow)
End If
End If
RowNum = RowNum + 1
Next
If Not rngtodelete Is Nothing Then rngtodelete.Delete xlUp 'Delete in one go
End With
Application.ScreenUpdating = True
End Sub
You can also learn a lot if you read this POST.
I don't really know if this is what you're trying to achieve.
I based it solely on the code you posted. This took less than a second in my machine. HTH.
You should try this:
Sub CombineRows()
'define variables
Dim RowNum As Long, LastRow As Long
Application.ScreenUpdating = False
'start below titles and make full selection of data
RowNum = 2
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'Range("A2", Cells(LastRow, 10)).Select
'For loop for all rows in selection with cells
'For Each Row In Selection
' With Cells
'if order number matches
With Worksheets("ABC") ' Whatever is the Tab name
For RowNum = 2 To LastRow
If .Cells(RowNum, 4) = .Cells(RowNum + 1, 4) Then
'move attribute 2 up next to attribute 1 and delete empty line
.Range(.Cells(RowNum + 1, 1), .Cells(RowNum + 1, 10)).Copy _
Destination:=.Range(.Cells(RowNum, 11), .Cells(RowNum, 20))
'Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 11)
'Cells(RowNum + 1, 2).Copy destination:=Cells(RowNum, 12)
'Cells(RowNum + 1, 3).Copy destination:=Cells(RowNum, 13)
'Cells(RowNum + 1, 4).Copy destination:=Cells(RowNum, 14)
'Cells(RowNum + 1, 5).Copy destination:=Cells(RowNum, 15)
'Cells(RowNum + 1, 6).Copy destination:=Cells(RowNum, 16)
'Cells(RowNum + 1, 7).Copy destination:=Cells(RowNum, 17)
'Cells(RowNum + 1, 8).Copy destination:=Cells(RowNum, 18)
'Cells(RowNum + 1, 9).Copy destination:=Cells(RowNum, 19)
'Cells(RowNum + 1, 10).Copy destination:=Cells(RowNum, 20)
Rows(RowNum + 1).EntireRow.Delete
End If
Next
'End With
End With
'increase rownum for next test
RowNum = RowNum + 1
'Next Row
'turn on screen updating
Application.ScreenUpdating = True
End Sub