VBA Paste Data After Last Row Issue - vba

I am compiling data from multiple worksheets to place on one consolidated sheet. The first sheet is easy because I can paste the entire sheet however after that it becomes tricky as I only need from A5-H### as I no longer need the header. I then need to paste this information at the bottom of the previous paste. I am getting a Range of Object "_Global" failed for the 'Range(lastRow).Select'. The issue is when I look at it in the debugger it is coming up with the correct row number. What am I doing wrong?
Sheets(1).Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Consolidation Sheet").Select
Range("A1").Select
ActiveSheet.Paste
Sheets(2).Select
Range("A5:A925").Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Consolidation Sheet").Select
Range("A5").Select
lastRow = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row + 1
Range(lastRow).Select
ActiveSheet.Paste

You need your Range statement in the following form (for example):
Range("A1").Select
So since you've got the row number (lastRow), you just need to add the column reference too:
Range("E" & lastRow).Select
Extra info
Avoid using Select by referring directly to the worksheets/ ranges you want to deal with
Sheets(1).Cells.Copy Destination:=Sheets("Consolidation Sheet").Range("A1")
With Sheets(2)
.Range(.Range("A5:A925"),.Range("A5:A925").End(xlToRight)).Copy
End With
With Sheets("Consolidation Sheet")
.Cells(.Rows.Count, "E").End(xlUp).Offset(1,0).PasteSpecial
End With

Related

Runtime error '1004' : You cant past this here cause the Copy area and past area arent the same size

I have a macro that copies a list of numbers from column A on the first sheet, and pastes it starting at the first blank cell in column A on the second sheet.
Sheets("TNF").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("TNF Check").Select
Range("A1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Basically, it uses the CTRL+SHIFT+Down function to select everything from A2 down.
It works fine when there is more than one cell to copy. But when there is only one cell, it grabs the entire column A (1048576 cells) and tries to paste it all on the second sheet, which doesnt fit (data is already there).
How can i update the code to not grab the whole column, but rather, only grab cells with data actually in it?
Use xlup:
Sheets("TNF").Range("A2",Sheets("TNF").Range("A" & Rows.Count).End(xlup)).Copy
Sheets("TNF Check").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Or better avoid the clipboard when only wanting values:
Dim rng as Range
Set rng = Sheets("TNF").Range("A2",Sheets("TNF").Range("A" & Rows.Count).End(xlup)).Value
Sheets("TNF Check").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(rng.Rows.Count,1).Value = rng.Value
We can add a simple logic like this.
Replace:
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
With this:
If Range("A3").Value = "" Then
Range("A2").Select
Else
Range(Range("A2"), Range("A2").End(xlDown)).Select
End If

vba filtering multiple sheets based on the same criteria

hopefully an easy question but not for a newbie like me... I have a workbook with master data and ca. 15 sheets, sheets 3-11 have data in the same format, which I want to filter by the same number, then delete other data and save. My (very amateurish) attempt was:
Sub Filterdata()
'Tab 3 - Vehicle info - filter by column A
Sheets("Vehicle Info").Select
ActiveSheet.Range("$A$1:$Q$10000").AutoFilter Field:=1, Criteria1:="<>1", _
Operator:=xlAnd
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.ClearContents
ActiveSheet.Range("$A$1:$Q$10000").AutoFilter Field:=1, Criteria1:="<>"
'delete blanks
ActiveSheet.Range("$A$1:$S$10000").AutoFilter Field:=1
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Range("A2").Select
'
'Tab 4 - Gifts - filter by column A
Sheets("Gifts to third parties (£50+)").Select
ActiveSheet.Range("$A$1:$Q$10000").AutoFilter Field:=1, Criteria1:="<>1", _
Operator:=xlAnd
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.ClearContents
ActiveSheet.Range("$A$1:$Q$50000").AutoFilter Field:=1, Criteria1:="<>"
'delete blanks
ActiveSheet.Range("$A$1:$S$50000").AutoFilter Field:=1
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Range("A2").Select
there were 10 more paragraphs like that, each relating to another worksheet within the same workbook - all need to be filtered in the same column (A) using the same number (1, in this case).
Could I replace this massive code with something shorter? (the first two worksheets also need to be filtered but by column B but because there is only two paragraphs, I can live with that), thank you.
Thank you for your help, the code seems to work perfectly on the first tab but then continues for a long time and when interrupted, " .Rows(x).Delete shift:=xlShiftUp" code is highlighed. Please find attached a screenshot showing the structure of the document, the two sheets in red have the company number in column B, other sheets have the company number in column A.
Some sheets may not have any data for e.g. company 3, then I'd need to delete all other irrelevant data (for other companies) and leave the tab blankenter image description here
This should work slightly better than the previous version. Let me know if you have any other issues
Sub Test()
Dim ws As Worksheet
Dim ShNum As Integer
Dim rwCcnt As Long
Dim num As Long
Dim x As Long
For num = 1 To 25 '---Number of companies to loop
For ShNum = 3 To 11 '---Sheets to loop
Set ws = Worksheets(ShNum)
rwCnt = ws.Cells(Rows.Count, 1).End(xlUp).Row
With ws
For x = rwCnt To 2 Step -1 '---Rows to loop
If .Cells(x, 1).Value2 <> num Or .Cells(x, 1).Value2 = "" Then
If x = 2 And .Cells(x, 1).Value2 = "" Then Exit For
.Rows(x).Delete shift:=xlShiftUp
End If
Next x
End With
Next ShNum
Next num
End Sub

Copying and pasting multiple columns into another worksheet using vba

I'm working on a code that will copy several columns of data that are not in order. I couldn't figure out how to do it in one step so i was trying to get it in two. After the first set of columns posts I'm having trouble getting it to go back to the sheet I was on to copy the next set of columns. This is what my code looks like so far.
Survey_Macro1 Macro
range("A:D").Select
range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add.Name = "Data"
ActiveSheet.Paste
ThisWorkbook.Save
ThisWorkbook.Sheets("Table").Activate
Application.CutCopyMode = False
range("AK:AL").Select
range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ThisWorkbook.Worksheets("Data").range(E1).Select
ActiveSheet.Paste
See How to avoid using Select in Excel VBA macros.
Sub yg23iwyg()
Dim wst As Worksheet
Set wst = Worksheets.Add
wst.Name = "Data"
With Worksheets("Table")
.Range(.Cells(1, "A"), .Cells(.Rows.Count, "D").End(xlUp)).Copy _
Destination:=wst.Cells(1, "A")
.Range(.Cells(1, "AK"), .Cells(.Rows.Count, "AL").End(xlUp)).Copy _
Destination:=wst.Cells(1, "E")
'alternate with Union'ed range - becomes a Copy, Paste Special, Values and Formats because of the union
.Range("A:D, AK:AL").Copy _
Destination:=wst.Cells(1, "A")
End With
End Sub

Returning to starting worksheet

I've recorded a quick macro which moves from my starting worksheet to a different worksheet, copies some cells and then goes back to the original worksheet to paste the contents of the copied cells.
While recording the macro the worksheet had a certain name and I'm trying to understand how to change it so that the macro will return to whatever worksheet I was on when initiating the macro and not returning to a specifically named macro.
This is what the code looks like:
Sheets("vlookup template").Select
Range("A1:K1").Select
Selection.Copy
Sheets("Sheet8").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("vlookup template").Select
Range("B2:K2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet8").Select
Range("B2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("B2:K11")
Range("B2:K11").Select
Selection.Copy
I want to change it so that instead of going to 'sheet8' it returns to the original sheet.
Dim homeSheet As WorkSheet
Set homeSheet = ActiveSheet
'.... Do stuff
homeSheet.Activate
Please see Avoid Select and Activate for more information.

Copy cells by row containing text to column on another worksheet

I'm fairly new to macros etc..and I've been trying to figure this problem out for a few days now!
I'm trying to go from a large spreadsheet of data, selecting specific cells based on the contents of specific cells, and paste into another worksheet.
Source spreadsheet:
Columns go: Site, Sub-location, Date, Month, Inspector, Action 1, Action 2 etc up to a max of 67 actions for each inspection.
Each row is a separate inspection submission
Target spreadsheet:
Columns go: Site, Sub-location, Date, Month, Inspector, Action, Due date of Action
where each row is a separate action.
I want it to skip pasting any values from the actions columns that would be blank (since no action is required). When it pastes the actions, it will also paste the first 5 columns (with site name, location, date etc), so that the action can be identified to the right site, date etc.
Hopefully that makes sense. By the end, I want the target spreadsheet to be able to be filtered by whatever the people need, e.g. by due date, or by location etc.
Code that I tried my hardest to get working...Unfortunately I can only get it working for the first row, and then it still pastes the blank (or zero) values and I need to filter them out. I'm thinking some sort of loop to do all the rows.
Sub test1257pm()
Application.ScreenUpdating = False
Sheets("Corrective Actions").Select
Range("A3:E3").Select
Selection.Copy
Sheets("Corrective Actions Tracker").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("Corrective Actions").Select
Range("F3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Corrective Actions Tracker").Select
Range("F3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0).PasteSpecial
Rows("2:2").Select
Selection.AutoFilter
Range("F4").Select
ActiveSheet.Range("$A$2:$L$300").AutoFilter Field:=6, Criteria1:=Array( _
"CMC to conduct clean of ceiling fans. Close out by 17/04/2014", _
"Provide bins", "Send to contractor", "="), Operator:=xlFilterValues
Application.ScreenUpdating = True
End Sub
Many thanks to anyone that can give me any assistance! :)
Edit:24-4-2014
Okay so after L42's code, it works fine if I could just consodidate my data first before putting it in the 1 column (stacking). The code I tried (using Macro recorder) is:
Sub Macro2()
Dim r As Range
Dim i As Integer
For i = 3 To 10
Range("P" & i).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Range("F" & i).Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=True, _
IconFileName:=False
Next i
End Sub
My problem with this is that it gives unexpected results...it doesn't consolidate it all into rows how I would expect. I'm thinking that this isn't the best solution...and probably the original macro needs to be changed..however I'm not sure how.
Overhaul #1: Using the provided sample data
Option Explicit '~~> These two lines are important
Option Base 1
Sub StackMyActions()
Dim sourceWS As Worksheet, targetWS As Worksheet
Dim staticRng As Range, copyRng As Range
Dim inspCnt As Long, i As Long, fRow As Long, tRow As Long
Dim myactions
Set sourceWS = ThisWorkbook.Sheets("Corrective Actions")
Set targetWS = ThisWorkbook.Sheets("Corrective Actions Tracker")
With sourceWS
'~~> count the total inspection
'~~> here we incorporate .Find method finding the last cell not equal to 0
inspCnt = .Range("A3", .Range("A:A").Find(0, [a2], _
xlValues, xlWhole).Offset(-1, 0).Address).Rows.Count
'~~> set the Ranges
Set copyRng = .Range("F3:BT3")
Set staticRng = .Range("A3:E3")
'~~> loop through the ranges
For i = 0 To inspCnt - 1
'~~> here we use the additional code we have below
'~~> which is GetCARng Function
myactions = GetCARng(copyRng.Offset(i, 0))
'~~> this line just checks if there is no action
If Not IsArray(myactions) Then GoTo nextline
'~~> copy and paste
With targetWS
fRow = .Range("F" & .Rows.Count).End(xlUp).Offset(1, 0).Row
tRow = fRow + UBound(myactions) - 1
.Range("F" & fRow, "F" & tRow).Value = Application.Transpose(myactions)
staticRng.Offset(i, 0).Copy
.Range("A" & fRow, "A" & tRow).PasteSpecial xlPasteValues
End With
nextline:
Next
End With
End Sub
Function to get the actions:
Private Function GetCARng(rng As Range) As Variant
Dim cel As Range, x
For Each cel In rng
If cel.Value <> 0 Then
If IsArray(x) Then
ReDim Preserve x(UBound(x) + 1)
Else
ReDim x(1)
End If
x(UBound(x)) = cel.Value
End If
Next
GetCARng = x
End Function
Results:
1: Using your sample data which looks like below:
2: Which after running the macro stacks the data like below:
Above code only stack inpections with at least 1 Action.
For example, Site 3 which was conducted by MsExample do not reflect on the Corrective Actions Tracker Sheet since no action was posted.
Well I really can't explain it enough, all the properties and methods used above.
Just check out the links below to help you understand most parts:
Avoid Using Select
Using .Find Method
Returning Array From VBA Function
And of course practice, practice, practice.