Sub InsertRow()
Dim rActive As Range
Set rActive = ActiveCell
Application.ScreenUpdating = False
With Cells(Rows.Count, "A").End(xlUp)
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteAll
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.DisplayAlerts = True
End Sub
My problem is, when my file is shared with others (share workbook), myself and them can save and everything and add rows, but the thing is the data validation is not copied in the new line and the drop down won't appear.
Anyone can help?
Try this. Your code worked for me so it looks like it might be something related to sharing (as per my comment).
Sub InsertRow()
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
With this code of #Captain Grum
Sub InsertRow()
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
It copies now the data validation below, but the borders and formula won't copy.
Please see this picture
I'm really sorry guys. I'm really just new to programming. I now have the solution to my problems. I just have included the code of #captain grumpy and mine above. Here's the code:
Sub InsertRow()
Dim rActive As Range
Set rActive = ActiveCell
Application.ScreenUpdating = False
With Cells(Rows.Count, "A").End(xlUp)
.Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteAll
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Related
I am quite inexperienced with vba and I am trying to make a code.
I am running it and it works fine but it is too slow when I have many rows. And with slow I mean that it could be running for minutes. I didnt waited till the end yet.
I would be very grateful for some help
Sub importart_lv()
Application.ScreenUpdating = False
Dim CL As Range
Dim rng As Range: Set rng = ActiveSheet.Range("A1:A2500")
For Each Cell In rng.Cells
If Cell.Value = "Position" Then
Cell.Offset(0, 6).Select
Worksheets("Bausteine").Activate
Range("G9:U9").Select
Selection.Copy
Worksheets("LV-Importieren").Activate
Selection.Insert
FindReplace
End If
'Cell.Offset(0, 11).Value = IIf(InStr(1, Cell, "Position"), "True", "")
Next
Application.CutCopyMode = False
ActiveSheet.Range("J1").Select
Worksheets("Bausteine").Activate
Range("G8:U8").Select
Selection.Copy
Worksheets("LV-Importieren").Activate
Selection.Insert
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I need some advice to rectify the code below. I have this code to copy paste lines to another sheet for data compilation purpose. And I'm running well using the with statement below, the problem is, when there's no data to paste, I do not know how to end the code with message box.
I see the similar question above, but how to comply the code into the With statement of VBA below?
Following is the code I read from other user, to return message box if error.
If Err Then
MsgBox "Nothing to paste!"
Err.Clear
End If
My original code, without the Message box return.
*Sub FnLstRow()
Application.ScreenUpdating = False
Dim LR As Long
ThisWorkbook.Worksheets("Data").Select
LR = Cells(Rows.Count, "AO").End(xlUp).Row
Cells(LR, 1).Offset(1, 0).EntireRow.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
With Sheets("LatestData")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
Range("A1").Select
Application.ScreenUpdating = True
End Sub**
this is a suboptimal solution that might not work but you could try: I created a dynamic array and tried to pass your entire selection into it. If the selection had no values, it will select all of the remaining cells in the sheet, and it is likely too large to pass into the array, resulting in a run time error. I didn't touch your code except for creating the array and adding the error handling section. I hope it works lol
Sub FnLstRow()
Application.ScreenUpdating = False
Dim LR As Long
Dim Arr() As Variant
ThisWorkbook.Worksheets("Data").Select
LR = Cells(Rows.Count, "AO").End(xlUp).Row
Cells(LR, 1).Offset(1, 0).EntireRow.Select
Range(Selection, Selection.End(xlDown)).Select
On Error GoTo Handler
Arr = Selection
On Error GoTo 0
Selection.Copy
With Sheets("LatestData")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
Range("A1").Select
Application.ScreenUpdating = True
Exit Sub
Handler:
MsgBox "Nothing to paste!"
End Sub
I'm trying to copy data from one workbook to another after a button click but the function range doesn't work and always returns
error 9 "out of range".
Sub Button1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open "C:\Users\Username\Desktop\Allineamento\Data\MasterData.xlsx"
Workbooks("MasterData").Sheets(2).range(Cells(13, 2), Cells(800, 16)).Copy
Workbooks("ImportSheets").Sheets("Master Data").Cells(2, 1).PasteSpecial Paste.Value
Workbooks("MasterData").Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
With basic Excel functions, the Macro-recorder is really useful. This is the code, generated by copying and pasting some excel range:
Sub Macro1()
Range("A1:E8").Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
ActiveSheet.Paste
Application.CutCopyMode = False
Range("L5").Select
Application.WindowState = xlNormal
Range("B7").Select
End Sub
Although, the code is not efficient, it is quite useful to see the needed code for the copy-paste - Range.PasteSpecial xlPasteValues
Thus, in the question code, replace PasteSpecial Paste.Value with PasteSpecial xlPasteValues.
I would like to insert the user name of the 'creator' (person who inserts) new row. I want the user name entered in column G.
I currently have the following macro to insert the row:
Sub Insert_Row()
Dim rActive As Range
Set rActive = ActiveCell
Application.ScreenUpdating = False
With Cells(Rows.Count, "H").End(xlUp)
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteFormulas
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
You just need to track the inserted row and set column G to the username, like this:
Sub Insert_Row()
Dim rActive As Range
Dim insertRow As Long
Set rActive = ActiveCell
Application.ScreenUpdating = False
With Cells(Rows.Count, "H").End(xlUp)
insertRow = .Row + 1
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteFormulas
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
Cells(insertRow, "G").Value = Environ("Username")
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I have a really weak experience working with VBA, but now faced an issue where it is really required.
I need to copy cell's value from multiple worksheets (besides "Summary") into one worksheet, but facing a problem. When running a macro, I get around 30 lines with the values I need, but all 30 values belong to the same worksheet. Seems like the loop is running only around 1 worksheet. Could you help me finding the mistake in the code?
Sub CopyTotalSalesPrice()
For Each Worksheet In ActiveWorkbook.Worksheets
If Worksheet.Name <> "Summary" Then
Worksheet.Cells(Rows.Count, 7).End(xlUp).Select
End If
If Selection.Value > "0" Then
Selection.Copy
Worksheets("Summary").Cells(Rows.Count, 6).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
Range("D4").Select
Selection.Copy
Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
End If
Next Worksheet
Worksheets("Summary").Select
End Sub
when using Cells(Rows.Count, 7).End(xlUp).Select and everything else, they refer to the current sheet. So you either put in front of them Worksheet.Cells(Rows.Count, 7).End(xlUp).Select or you activate the sheet first with Worksheet.Activate
or you can just do as follow:
Sub CopyTotalSalesPrice()
For Each Worksheet In ActiveWorkbook.Worksheets
With Worksheet
If .Name <> "Summary" Then
.Cells(Rows.Count, 7).End(xlUp).Copy Destination:=Worksheets("Summary").Cells(Rows.Count, 6).End(xlUp).Offset(2, 0)
.Range("D4").Copy Destination:=Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp).Offset(2, 0)
End If
End With
Next Worksheet
Worksheets("Summary").Select
End Sub
Try this:
Sub CopyTotalSalesPrice()
For Each Worksheet In ActiveWorkbook.Worksheets
If Worksheet.Name <> "Summary" Then
Worksheet.Select
Worksheet.Cells(Worksheet.Rows.Count, 7).End(xlUp).Select
End If
If Selection.Value > "0" Then
Selection.Copy
Worksheets("Summary").Cells(Worksheet.Rows.Count, 6).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
Range("D4").Select
Selection.Copy
Worksheets("Summary").Cells(Worksheet.Rows.Count, 4).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
End If
Next Worksheet
Worksheets("Summary").Select
End Sub
I replaced this Cells(Rows.Count, 7).End(xlUp).Select with Worksheet.Cells(Worksheet.Rows.Count, 7).End(xlUp).Select