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
Related
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
I am new to VBA and have primarily used it in conjunction with creating a macro. As you can see from the code below, I am trying to take tables from three different tabs and merge them into one. However, I am having a hard time understanding how to ensure that each table will paste directly underneath the previous table and not overwrite it (especially when each month new rows are created).
Thank you in advance for any help you can provide.
' Step_4_Combination_Tab Macro
Sheets("Past Data").Select
Range("A2:M2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Combination").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Selection.End(xlDown).Select
Range("A5483").Select
Sheets("Actual").Select
Range("A5:M5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Combination").Select
Range("A5483").Select
ActiveSheet.Paste
Range("A5483").Select
Selection.End(xlDown).Select
Range("A8341").Select
Sheets("Forecast").Select
Range("A4:M4").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Combination").Select
ActiveSheet.Paste
Selection.End(xlUp).Select
End Sub
The following code might do what you want:
Sub mergeSheets()
Set targetSheet = Sheets("Combination")
For i = 1 To Sheets.Count
If Sheets(i).Name <> "Combination" Then
Last = LastRow(Sheets("Combination"))
Sheets(i).UsedRange.Copy targetSheet.Cells(Last + 1, 1)
End If
Next i
End Sub
Function LastRow(sh As Worksheet)
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End Function
some codebits taken from here https://www.exceltip.com/cells-ranges-rows-and-columns-in-vba/copy-the-usedrange-of-each-sheet-into-one-sheet-using-vba-in-microsoft-excel.html
You will need to find the last row that has data and paste you next table there.
LR = Sheets("Combination").Range("A" & Rows.Count).End(xlUp).Row
Pasterange = "A" & LR
Sheets("Combination").Range(Pasterange).Paste
I am guessing that you want to copy data from tabs "Past data", "Actual" and "Forecast" to "Consolidated". Am I right? And for some odd reason data in source worksheets begins in different rows. I would do it this way:
Sub AllToCons()
CopyToCons "Past data", 2
CopyToCons "Actual", 5
CopyToCons "Forecast", 4
End Sub
Sub CopyToCons(wsName As String, lRow As Long)
'wsName: name of sheet we are copying from
'lRow: number of row where data start
Dim ws As Worksheet
Dim wsCons As Worksheet
Dim rng As Range
Set wsCons = ThisWorkbook.Worksheets("Consolidated")
Set ws = ThisWorkbook.Worksheets(wsName)
With ws
Set rng = Range(.Range("A" & lRow), .Range("M" & .Cells.Rows.Count).End(xlUp))
End With
rng.Copy
With wsCons
.Range("A" & .Cells.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
End With
If you want to paste values only, type xlPasteValues instead of xlPasteAll.
Hope it helped.
This code is a bit complex but the problem with it is the second and third time it is run it will start to lose columns on the "Base434" worksheet that it pulls information from. I tried a quick fix of adding "Range("A1").Select so that anything previously highlighted couldn't throw it off but it keeps ditching the 20th row which is column "T". I have left all of the code below in hope that someone can find my bug. I just cannot sort it.
Essentially this code sorts set fields of data on an imported worksheet called "Base434", copies specific fields to another page which has some embeded formulas then checks to see if the worksheet "NoStdHC" exists. If it doesn't it will create said worksheet and add the header. Then move to the filtered worksheet called "Base434" and copy all visible cells in that worksheet. It will then paste those in the first available cell in column A of "NoStdHC". My issue is after running this once it refuses to copy the final column on the next "Base434" sheet that has been imported. Can anyone find the fault in my code? Yes I know a lot of this could be condensed if I were better at coding but I would prefer to understand what the code is doing which is why I have it written this way.
Sub NoStdHC()
'
' NoStdHC Macro created by
'
'
Application.ScreenUpdating = False
Sheets("Base434").Select
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
ActiveSheet.Range("A1:T" & LastRow).AutoFilter Field:=15
ActiveSheet.Range("A1:T" & LastRow).AutoFilter Field:=10
ActiveSheet.Range("A1:T" & LastRow).AutoFilter Field:=10, Criteria1:="<=.5", _
Operator:=xlAnd
Columns(11).Cells.SpecialCells(xlCellTypeVisible).Cells(2).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Processing").Select
Range("AC1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C5").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=COUNTA(C[26])"
Range("e5").Select
ActiveCell.FormulaR1C1 = "=SUM(C[24])"
Range("C8").Select
Sheets("Base434").Select
Dim wsTest As Worksheet
Const strSheetName As String = "PR0OnStd"
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.Name = strSheetName
Sheets("Base434").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("PR0OnStd").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Columns.AutoFit
Range("A2").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
End If
Sheets("Base434").Select
Range("a1").Select
Columns(1).Cells.SpecialCells(xlCellTypeVisible).Cells(2).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("PR0OnStd").Select
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & LastRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.ScreenUpdating = True
End Sub'
As commented by #A.S.H avoid using Select/Activate/ActiveCell if at all possible. Ranges should be qualified by using their sheet names. With...End With constructs achieve both of these goals. The With statement allows you to perform a series of statements on a specified object without requalifying the name of the object.
Indentation makes code much easier to read and understand.
With the foregoing in mind I think this code is understandable
Sub NoStdHC()
Dim LastRow As Long
Dim sht As Worksheet
Application.ScreenUpdating = False
With Sheets("Base434")
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
.Range("A1:T" & LastRow).AutoFilter Field:=10, Criteria1:="<=.5"
.Range(.Cells(2, 11), .Cells(LastRow, 11)).Copy
End With
With Sheets("Processing")
.Range("AC1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("C5").FormulaR1C1 = "=COUNTA(C[26])"
.Range("E5").FormulaR1C1 = "=SUM(C[24])"
End With
Dim wsTest As Worksheet
Const strSheetName As String = "PR0OnStd"
'Loop through sheets to find strSheetName
'if not found, then wsTest will be Nothing
For Each sht In ThisWorkbook.Sheets
If sht.Name = strSheetName Then
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
Exit For
End If
Next
If wsTest Is Nothing Then
'Add the sheet, set up headings, column widths and frozen pane
Worksheets.Add.Name = strSheetName
With Sheets("Base434")
.Range("A1", .Range("A1").End(xlToRight)).Copy
End With
With Sheets("PR0OnStd")
.Range("A1").PasteSpecial xlPasteValues
.UsedRange.Columns.AutoFit
End With
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
End If
With Sheets("Base434")
.Range(.Cells(2, 1), .Cells(LastRow, 2).End(xlToRight)).Copy
End With
With Sheets("PR0OnStd")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & LastRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
End Sub
If you wanted to write write code you can easily understand you wouldn't write code like this:-
Sheets("Base434").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
This is what your code says, translated into plain language:-
Look at sheet "Base434"
Look at cell A1 (implied: in that sheet)
Look at what you are looking at and extend your view to the last ??? right
(This is where the mistake is)
Copy what you are looking at.
Now, surely, if you wanted to understand what all this looking is aiming to do you might express the idea somewhat like this:-
Copy the cells in Row 1 of Sheet "Base434" from A1 to the end of the row.
With this kind of approach you would end up with code like this:-
Dim RangeToCopy As Range
Dim Cl As Long ' the last used column
With Worksheets("Base434")
Cl = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set RangeToCopy = .Range(.Cells(1, 1), .Cells(1, Cl))
End With
MsgBox "Range to copy = " & RangeToCopy.Address
RangeToCopy.Copy
Would you say that this code is harder to read and understand than your version? Well, it has three advantages, even if it is. One, it doesn't have the fault that yours has. Two, it never got near to wanting to make the mistake that your approach made. Three, whatever errors it might still contain are easy to find and quick to eliminate.
Besides, it runs faster.
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
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.