I have a range of data that is in the same position in every worksheet in a book and will always be in that position. When the macro is run the data should be copied and added to a report sheet. I have that part working but I need to use a paste special:
.PasteSpecial xlPasteValues
as there are formulas in the range. I am unsure where to add the paste special condition in this code, since I'm using .Copy, Destination.
Option Explicit
Sub CreateTempPSDReport()
Dim WS As Worksheet, Rept As Worksheet
Set Rept = Sheets("Temporary PSD Report")
Application.ScreenUpdating = False
'--> Loop through each worksheet except the report and
'--> Copy the set range to the report
For Each WS In ThisWorkbook.Worksheets
If Not WS.Name = "Temporary PSD Report" Then
WS.Range("A42", "I42").Rows.Copy _
Destination:=Rept.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next
Application.ScreenUpdating = True
End Sub
I need to use a paste special:
WS.Range("A42", "I42").Rows.Copy _
Destination:=Rept.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
In such a case you do not use the above method. You use this
WS.Range("A42", "I42").Rows.Copy
Rept.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Related
I put together code to copy data pulled by formulas and then paste it as values within the same sheet. I have multiple workbooks that vary in the amount of worksheets/tabs they contain.
Problem #1:
My first worksheet on every file is called REGION.
The code is not executing on the "REGION" worksheet as designed and is also skipping the worksheet immediately after it.
Problem #2
Depending on the workbook, after 6 worksheets, I get
Run-Time Error '1004'
Problem #3
On workbooks small enough for the code to cycle through all worksheets and not finding any more worksheets to apply the code I get
Error 400
In summary, I need to:
1. Figure out why the code is skipping the worksheet immediately after the one called REGION (1st Tab)
2. Prevent error '1004' because the program is performing the same function over and over on multiple worksheets (read that I should probably set it to save every few tabs to prevent this but not sure how to do it while looping).
3. Add to the code a line that stops the cycle without throwing an error message.
Sub COPYPASTE()
Dim ws As Worksheet
For Each ws In Sheets
If ws.Name <> "REGION" Or ws.Name <> "Legend" Then
Range("C3:I47").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
End If
ActiveSheet.Next.Select
Next
End Sub
Avoid using Select and/or Activate (and related: ActiveSheet, etc.) and while we're at it, rather than Copy/PasteSpecial, just do a direct value-assignment using the range's Value property.
So that this:
Dim ws As Worksheet
For Each ws In Sheets
If ws.Name <> "REGION" Or ws.Name <> "Legend" Then
Range("C3:I47").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
End If
ActiveSheet.Next.Select
Next
Becomes this (also note the Or should be an And, I think)
Dim ws As Worksheet
Dim rng as Range
For Each ws In Sheets
'Do not operate on either of Region or Legend worksheets
If ws.Name <> "REGION" And ws.Name <> "Legend" Then
Set rng = ws.Range("C3:I47")
rng.Value = rng.Value2
End If
Next
Here is a simple loop that is copying a range to another location on the same worksheet. This also needs to loop through all the remaining worksheets and perform the same copy paste values. My use of variable "Dim ws" in the loop is suspect.
Sub UpdateSPCData()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Select Case UCase(wsLoop)
Case "Data - MOAQ", "Report" 'Do nothing
Case Else
Range("H2:H5").Copy
Range("I2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Select
Next ws
End Sub
I think you need this. Also, if checking upper case names you must make sure you are comparing with upper case text.
Sub UpdateSPCData()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Select Case UCase(ws.Name)
Case "DATA - MOAQ", "REPORT" 'Do nothing
Case Else
ws.Range("H2:H5").Copy
ws.Range("I2").PasteSpecial Paste:=xlPasteValues
End Select
Next ws
End Sub
Sub CPRow()
Range("D14:K14").Select
Selection.Copy
Range("D15").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
i want to add code to do the following:
1- if the sheet name begins with a number then copy the range (D14:K14) and paste it in Range (D15:K15) as Values.
2- Go to next sheet and do the same, and stop when there is a sheet with no number or until sheet name starts with a letter.
Any help is appreciated.
The code below will copy Range("D14:K14") form Worksheets("Sheet1") (modify "Sheet1" to your sheet's name), and paste it to all worksheet's that their Name start with a number.
Option Explicit
Sub CPRow()
Dim Sht As Worksheet
Dim ShttoCopy As Worksheet
Set ShttoCopy = Worksheets("Sheet1") ' <-- modify "Sheet1" to the sheet you want to copy Range("D14:K14") from
For Each Sht In ThisWorkbook.Worksheets
If IsNumeric(Left(Sht.Name, 1)) Then
ShttoCopy.Range("D14:K14").Copy
Sht.Range("D15").PasteSpecial xlPasteValues
End If
Next Sht
End Sub
I am new to the VBA and Macro world. I am trying to create a data collection sheet. First part data is collected in from 1 workbook and placed in workbook master. What I would like to achieve is the new data that I extract will be placed below the previous entry in the workbook master.
Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
Sheets("For Coordinator Use").Select
Range("A2:M41").Select
Selection.Copy
Windows("Nimble Schedule Import Template- ops.xlsx").Activate
Range("A1000").End(xlUp).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
"=0", Operator:=xlOr, Criteria2:="="
Application.CutCopyMode = False
Selection.EntireRow.Delete
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
Windows("Coverage Request Form (9).xlsx").Activate
Sheets("Request Form").Select
End Sub
Here is a modified and commented copy of your code:
Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
Sheets("For Coordinator Use").Select
Range("A2:M41").Copy 'No need to select then copy, just copy is fine
Windows("Nimble Schedule Import Template- ops.xlsx").Activate
'I have offset the last row of data by 1 row below, use rows.count rather than a hard row number. Also no need to select
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="=0", Operator:=xlOr, Criteria2:="="
'I don't know what row is selected here but it was in your code so I left it, also no need for cutcopymode as it will cancel when you delete anyway
Selection.EntireRow.Delete
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
Windows("Coverage Request Form (9).xlsx").Activate
Sheets("Request Form").Select
End Sub
Please read the comments and ask any questions about it where you are unsure. These changes are because you have stipulated you are new to this and I don't want to confuse you, this is NOT the best way to do it, I would much rather set up something with arrays than a copy and paste. If you are comfortable with this concept post back and I will modify my code for you.
It depends how you would like to do it. Do you want to maybe use an array to store the data in then extract to the master spreadsheet or do you want to just use excels built in functions to copy and paste the data like you are doing above. You could also use a scripting dictionary to store the data as well there are many ways to do it just wondering which route you want to take. If you want to have a high performance macro then I suggest not to use excel's built in functions as they are slower than using arrays.
Update 2015-08-20
I have got the copy and paste using the range object. However I see you want to delete some other values from your list although they are kept in a table and not in a spreadsheet. Is this correct? Please have a look at the code I made some comments asking for some clarifications. Sorry for taking so long I was busy finishing something up at work.
Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
Dim wb As Workbook, ws As Worksheet, rng As Range
Set wb = ThisWorkbook 'Set up the Excel objects you want to use
Set ws = wb.Worksheets("For Coordinator Use")
Set rng = ws.Range("A2:M41") 'asuming this is not changing
'Sheets("For Coordinator Use").Select 'You do not need to select if you use the objects
'Range("A2:M41").Select 'You do not need to select if you use the objects
'Selection.Copy 'you can also get rid of this if using objects
Dim wbDest As Workbook, wsDest As Worksheet, rngDest As Range
Set wbDest = Application.Workbooks("Nimble Schedule Import Template- ops.xlsx") ' Assuming that it is opened
'Windows("Nimble Schedule Import Template- ops.xlsx").Activate 'dont need to activate anything
Set wsDest = wbDest.Worksheets("Sheet1")
Set rngDest = wsDest.Range("A1:A35000")
''optimize the application
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
''''
'''Find the first empty cell in destRng
'Range("A1000").End(xlUp).Select ' this will select the range that is blank only if it does not have data to begin with
Dim i As Long, j As Long, rngAdd As String 'i is the counter and j stores the row where it is blank
For i = 1 To rngDest.Cells.Count
If IsEmpty(rngDest.Cells(i, 1).Value) Then
j = i
i = rngDest.Cells.Count
End If
Next i
'reset the rngDest
Set rngDest = Nothing
rngAdd = "A" & j & ":M" & (j + 39)
Set rngDest = wsDest.Range(rngAdd)
'make rngDest = rng.Value since they have the same dimension this works
rngDest = rng.Value 'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
' :=False, Transpose:=False
'I am not sure what you are trying to acheive here a filter??'ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
' "=0", Operator:=xlOr, Criteria2:="="
'Application.CutCopyMode = False
'Selection.EntireRow.Delete
'ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
''Looks like you are deleting all with a value of "=0"
'Windows("Coverage Request Form (9).xlsx").Activate
'Sheets("Request Form").Select
'Release Objects
Set rngDest = Nothing
Set wsDest = Nothing
Set wbDest = Nothing
Set rng = Nothing
Set ws = Nothing
Set wb = Nothing
''set excel optimization as normal again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAuto
Application.EnableEvents = True
End Sub
I have the following macro which has worked great for copy and paste, then the person working with the workbook goes to the newly created sheet and starts deleting rows not necessary to the end product. I have tried adding a line to have the macro delete blank rows, but it is not working. I think possibly because it is not on the active sheet? If I could get the macro to delete blank rows in the range I have added to the macro then I can build from there; as we have many ranges to look through and delete from. I am still learning about macros so any education you could give me would be much appreciated.
Here is the macro I have. It is the 'Delete lines from new sheet that is not working.
Sub CopyandPaste()
'Copy and Paste to Worksheets
'
'Select from MASTER sheet
Range("A1:H1500").Select
Selection.Copy
' Add new sheet for each Tech
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
'Copy again to paste values
Range("A1:H1500").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Name new sheet Tech's name
Sheets(Sheets.Count).Select
Sheets(Sheets.Count).Name = Sheets(Sheets.Count).Range("a2").Value
'Delete blank lines from new sheet
ActiveSheet.Range("F282:F834").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
The routine below is how I might tackle this task. Comments are included to help explain what's going on:
Option Explicit
Sub CopyAndPasteRev2()
Dim Source As Range, Dest As Range, Remove As Range
Dim Master As Worksheet, Target As Worksheet
'set references up-front, assuming you
'start with the MASTER sheet active
Set Master = ThisWorkbook.ActiveSheet
Set Source = Master.Range("A1:H1500")
Set Target = ThisWorkbook.Sheets.Add
Set Dest = Target.Range("A1")
'copy range from master to target
Source.Copy Destination:=Dest
'copy the column width formatting from master to target
Source.Copy
Dest.PasteSpecial (xlPasteColumnWidths)
'remove rows that are blank in col F using
'autofilter to look for empty cells
Dest.AutoFilter
With Target.AutoFilter.Range
.AutoFilter Field:=6, Criteria1:=vbNullString
Set Remove = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
Remove.Delete Shift:=xlUp
End With
'clear filters safely
With Target
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
'move target sheet to be the last one in the workbook
Target.Move After:=ThisWorkbook.Worksheets(Sheets.Count)
End Sub
In most case runtime exception are caused by the Select and ActiveSheet methods.
You need to use them less as possible and use Range and Worksheet variables instead :
Sub CopyandPaste()
'Copy and Paste to Worksheets
'
'Select from MASTER sheet
Dim MasterSheet As Worksheet
Set MasterSheet = Sheets("Master")
MasterSheet.Range("A1:H1500").Copy
Dim newSheet As Worksheet
' Add new sheet for each Tech
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
newSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
newSheet.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Copy again to paste values
Application.CutCopyMode = False
'Name new sheet Tech's name
On Error Resume Next
Sheets.Item(newSheet.Range("a2").Value).Delete
On Error GoTo 0
newSheet.Name = newSheet.Range("a2").Value
'Delete blank lines from new sheet
For i = 834 To 282 Step -1
With newSheet.Cells(i, "F")
If .Text = "" Then .EntireRow.Delete
End With
Next i
End Sub