Excel VBA insert row and copy data on multiple sheets - vba

I am trying to get the correct VBA code that will allow me to insert a row in to a filtered table at the same place on multiple worksheets and copy all of the content from the entire row above.
There is a check box relating to each sheet in the workbook. If the check box is ticked then the row should be inserted in to this sheet.
The sheets are password protected. The password is found in another of the worksheets in the file.
I have almost got this to work. My file can be found at the following location:
https://drive.google.com/file/d/0B5HnHgSNFkFid0gwbDNMOFN1NUU/view?usp=sharing
The code is as follows:
Sub Insert_Rows()
Dim sh As Worksheet
For Each sh In Sheets
If sh.Name = "Sheet1" And Worksheets("Sheet4").Range("D1").Value = True Or _
sh.Name = "Sheet2" And Worksheets("Sheet4").Range("D2").Value = True Or _
sh.Name = "Sheet3" And Worksheets("Sheet4").Range("D3").Value = True Then
With sh
.Unprotect Password:=Worksheets("Sheet4").Range("A1")
.Cells(ActiveCell.Row, 4).EntireRow.Insert
.Range(.Cells(ActiveCell.Row, 1), .Cells(ActiveCell.Row, 4)).FillDown
.Protect DrawingObjects:=True, contents:=True, Scenarios:=True, Password:=Worksheets("Sheet4").Range("A1")
End With
End If
Next sh
End Sub
The issue I am having is that not all of the data from the row above is being copied. The data in the 5th column is not copying down. I am sure it is something to do with the 4 in the code .Cells(ActiveCell.Row, 4). I want it to copy the entire row above regardless of the number of columns.
Any help greatly appreciated.
Thanks

To FillDown the EntireRow, instead of just the Range between column 1 and column 4, replace
.Range(.Cells(ActiveCell.Row, 1), .Cells(ActiveCell.Row, 4)).FillDown
with
.Cells(ActiveCell.Row, 1).EntireRow.FillDown
(which could also be written as .Rows(ActiveCell.Row).FillDown)
Note:
Please remember that ActiveCell.Row is not necessarily referring to any special location on Sheet1, Sheet2, or Sheet3.
If the currently active cell is cell G67 on sheet Sheet4, then ActiveCell.Row will evaluate to 67 and so row 66 of Sheet1 (and/or Sheet2 and/or Sheet3) will be copied to a newly inserted row on Sheet1 (and/or Sheet2 and/or Sheet3) - it won't magically decide to insert row 58 on Sheet1 and row 82 on Sheet2, etc.
If the only problem you are having is that the entire row is not being filled down, then the solution above will fix it. But if you find that the wrong row is being filled down, then you will need to rethink how you are selecting the row.

Related

Excel vba - paste below header

I need to copy a column from one workbook to another.
y.Sheets("data").Range("A2:A1048576").Clear 'delete contents of target columns first
x.Sheets("file").Range("C:C").Copy 'copy column from another sheet
y.Sheets("data").Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
I'm trying to paste it to starting from A2 since A1 is my header.
I'm getting a application-defined or object-defined error
It's best practice not to reference entire columns (some million cells) when you don't need to:
With y.Sheets("data") ' reference sheet "data" in workbook 'y'
.Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).ClearContents ' clear 'referenced sheet column "A" cells from row 2 down to last not empty one
End With
With x.Sheets("file") ' reference sheet "file" in workbook 'x'
With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp)) 'reference referenced sheet column "C" cells from row 1 down to last not empty one
y.Sheets("data").Range("A2").Resize(.Rows.Count).Value = .Value ' paste referenced range values to workbook "y" sheet "data" starting from cell A2
End With
End With
Or the following
With y.Sheets("data")
Intersect(.UsedRange, .Columns("A")).Clear
Intersect(x.Sheets("file").UsedRange, x.Sheets("file").Columns("C")).Copy .Range("A2")
End With
The issue here is you copy a complete column Range("C:C").Copy and that means you have to paste to a complete column otherwise it would not fit in and exceed Excel's maximum row count.
Therefore I suggest to copy only that part of column C that contains data:
With x.Sheets("file")
.Range("C1", .Cells(.Rows.Count, "C").End(xlUp)).Copy
End With
This copies only from C1 to the last used cell. And then you can paste it directly to A2
y.Sheets("data").Range("A2").PasteSpecial xlPasteValues

Copy/paste data into consolidated list

I'm stuck on how to structure a piece of code that:
Loops through all worksheets that begin with the number 673: (e.g. 673:green, 673:blue)
Selects the data in these worksheets from row 5 up until the last row with data - code that works for this (generously provided by another user) is
Dim report As Worksheet
Set report = Excel.ActiveSheet
With report
.Range(.Cells(5, "K"), .Cells(.Rows.Count, "K").End(xlUp)).EntireRow.Select
End With
Select the "Colours" worksheet
Paste the rows at the next available blank row. There could be up to 40/50 worksheets which will have data pasted into the "Colours" worksheet so I need the data added to the next available line.
Thank you in advance.
Loop over the sheets in the workbook and check their names
For Each sheet in ActiveWorkbook.Worksheets
If Instr(sheet.Name,"673")>0 Then
...
End If
Next
Good, but you're going to want to copy.
Selection.Copy
Just select.
Worksheets("Colours").Select
Find the last row then go to the next. The row is found by finding the first populated row from the bottom up. Note I used explicit sheet references, which is unnecessary since you selected the sheet already. This is better form, however, if you will be manipulating data on multiple sheets in your code.
lastRow = Worksheets("Colours").Cells(Worksheets("Colours").rows.count,1).End(xlUp).Row
Worksheets("Colours").Cells(lastRow + 1, 1).Select
Activesheet.Paste

How can I copy & paste entire rows with distinct values to a new sheet on varying cell ranges?

I know there's many StackOverlow Q&A's on copying & pasting from a cell value in VBA. However, I can't seem to make it work for my own project. I want to copy the entire row(s) if it matches the Distinct Store# (non incremental) in Column H into a new sheet (in this code below, "Sheet1") which already has a template layout where I copy/paste the values. The template looks the same on every sheet before any data is filled in, except the first 2 tabs which have the data ("Appointments" and "Invoices").
I came up with the VBA below, but here's the catch- the cell# that it pastes the row(s) (in the code below, "A10") changes based on the Store #. This is because I am copying rows from the 1st sheet ("Appointments") in the workbook from the distinct Store#, then deleting the empty rows above the area where the 2nd sheet ("Invoices") data goes. Some stores may return 10 rows or none at all. The Case, which is the Store #, is currently manually put in one by one. Should it be an array instead?
Anyway...I was hoping to automate the copying/pasting and loop for each store to their sheet. Maybe I'm going about this wrong, but would anyone be kind enough to suggest how to solve my error code "Method or data member not found." as well as provide any suggestions on making my code better for a loop for filtered cell copying to different spots for each sheet.
Simple explanation of my step by step process:
1.Filter Store # from "Appointments" sheet.
2. Copy all rows for that store and paste into a new sheet with template named "Sheet1" in B3.
3. Filter Store # from "Invoices" sheet.
4. Copy all rows for that store and paste into the previously made sheet named "Sheet" under the above rows. (Some stores do not have invoices, so this section is blank/NULL). Paste destination cell for "Invoices" will be different for each store# depending on how many rows they get from the "Appointments" sheet (could be A10 or A25).
5. LOOP- Next store #, next sheet (sheet2).
Sub CopyToNewSheetInv()
Dim i As Range
Dim book As Workbooks
Dim sheet1 As Worksheets
Dim sheet2 As Worksheets
Set book = Workbooks("SampleWorkbookName")
Set sheet1 = Worksheets("AllInvoices")
Set sheet2 = Worksheets("Sheet1")
For Each i In sheet1.Range("H:H")
Select Case i.Value
Case 1243
sheet2.Range("A10").End(xlUp).Offset(1, 0).EntireRow.Value = i.EntireRow.Value
Case Else
End Select
Next i
End Sub
Try this:
Sub CopyToNewSheetInv()
Dim i As Range
Dim book As Workbook
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Set book = Workbooks("SampleWorkbookName.xlsx")
Set sheet1 = book.Worksheets("AllInvoices")
Set sheet2 = book.Worksheets("Sheet1")
'iterate only thorugh those cells in H that have data, not all 1.04 million
For Each i In sheet1.Range("H1", sheet1.Range("H" & sheet1.Rows.Count).End(xlUp))
Select Case i.Value
Case 1243,"1243"
sheet2.Rows(sheet2.Range("A10000").End(xlUp).Offset(1, 0).Row).Value = sheet1.Rows(i.Row).Value
Case Else
End Select
Next i
End Sub

How to copy entire row from one sheet with specific value to another sheet (in different workbook)using macros

As a beginner in field of macros, I need advise on how to copy/paste an entire row if column R has value = "YES", from sheet "database", to the next available blank row in sheet2.
Also Sheet2 is another file/workbook at location "C:\Users\Desktop\KPIs"
Example assumes the workbook you want to paste to is already open.
If R1 is "YES" then it copies row 3 to row 3 in the Target workbook
Sub CopyRow()
Dim copyRng As Range
If Worksheets("Database").Range("R1") = "YES" Then
Worksheets("Database").Range("A3").EntireRow.Copy Destination:=Workbooks("Target").Worksheets("Sheet1").Range("A3")
End If
End Sub

VBA code in Excel to add a row to multiple sheets and then copy formula from adjacent row

I'm really hoping someone can help me with this one. I have recorded a macro to use within a sheet that needs to create a row at the same position on 2 worksheets and then, on one of them, copy the formula's in the cells from the row below it. The code I have looks like this -
Sub Macro1()
Sheets(Array("SCHEDULE", "ANNUAL SUMMARY")).Select
Sheets("SCHEDULE").Activate
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("ANNUAL SUMMARY").Select
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.AutoFill Destination:=ActiveCell.Offset(-1, 0).Rows("1:2").EntireRow _
, Type:=xlFillDefault
ActiveCell.Offset(-1, 0).Rows("1:2").EntireRow.Select
Sheets("SCHEDULE").Select
ActiveCell.Select
My problem is, when I run it manually and then record the macro, it does exactly what I want it to, but when I run this from a button on the "SCHEDULE" sheet it does not copy the formula's from the row below the one on the "ANNUAL SUMMARY" sheet.
Can anyone help to get this working with me?
Thanks all in advance
Mark
The problem with the macro recorder is that although it can give you a good indication of what code you need, it also generates very inefficient code and includes all of the select and activate statements that you need to try and avoid using.
Any reference in the code to ActiveCell is referring to the cell that is currently selected and ActiveSheet is the sheet that is currently selected. This can give you undesired results if you run the macro from a different sheet that the macro was recorded from...
If you wanted to copy row 1 from SCHEDULE sheet then you can use
Sheets("SCHEDULE").Rows(1).Copy Sheets("ANNUAL SUMMARY").Rows(1)
If you want to auto fill a range, then this can be accomplished with a single line of code
This will auto fill the contents of row1 (column A - E) down to row 100 in your ANNUAL SUMMARY sheet
Sheets("ANNUAL SUMMARY").Range("A1:E100").FillDown
So if we put it all together and include some declarations for our source and destination sheet to make the sub more readable..
Sub CopyAndFillDownExample()
Dim rowNumber As Long, offset As Long
Dim sourceSht As Worksheet, destinationSht As Worksheet
'set the source and destinationsheets
Set sourceSht = Sheets("SCHEDULE")
Set destinationSht = Sheets("ANNUAL SUMMARY")
'number of rows to copy down
offset = 100
'get currently selected row
rowNumber = ActiveCell.Row
'copy the selected row from the source sheet to the destination sheet
sourceSht.Rows(rowNumber).Copy destinationSht.Rows(rowNumber)
'fill down the formulas
destinationSht.Rows(rowNumber & ":" & rowNumber + offset).FillDown
End Sub