Sub Copy_Cell2()
'Declare Variables
Dim Wr As Worksheet
'Define the excel sheet
Set Wr = ThisWorkbook.Sheets("Sheet2")
'Code to stop screen updating and flickering ON
Application.ScreenUpdating = False
'Select Sheet1 to get the random value
Sheets("Sheet1").Select
Cells.Select
Range("F1").Select
Range("F1").Copy
'Selects Sheet2 to paste the random value in the next blank cell in column A
Sheets("Sheet2").Select
Range("A2").Select
nrlife = Wr.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
'Establish what row has been selected
With ActiveCell
vRow = .Row
End With
vRange = "A" & vRow & ""
Range(vRange).Select
'Code to paste value and format from Sheet1 to first empty row on sheet2
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks_:=False, Transpose:=False
'Code to stop screen updating and flickering OFF
Application.ScreenUpdating = True
End Sub
I am getting error in Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks_:=False, Transpose:=False
Error code is Run-time error '1004' Aplication-defined or
object-defined error
Can anyone help me what am i missing?
Your code reduces to:
Dim wb As Workbook
Set wb = ThisWorkbook
wb.Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = _
wb.Sheets("Sheet1").Range("F1").Value
You can assign values directly - no need for copy/paste in this case.
Related
I am trying to find the next blank cell in column N in order to select and copy the vale in the same row but in column I after autofiltering column B.
My code seems to find the next blank cell but doesn't take the filter into consideration finding the blank cell in rows not included in the filter.
Hope this makes sense
Edit: Apologies about the shite code, I typically recycle and string it all together etc.
Sub Replanning_Lasers()
startofloop:
Dim Orderbook As String
Dim Supply As String
Orderbook = Sheet25.Range("C14")
Supply = Sheet25.Range("D14")
If Orderbook > Supply Then GoTo endofloop
***Sheets("List").Select
Range("$B$4:$BN$1533").AutoFilter Field:=3, Criteria1:="LASER"
NextFree = Range("N5:" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).row
Range("I" & NextFree).Select***
Selection.Copy
Sheets("Planning").Select
Range("C9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Call BUT_Planning_reset
Call BUT_Planning_Find_First
Range("M9").Select
Selection.Copy
Sheets("List").Select
Range("N" & NextFree).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
GoTo startofloop
endofloop:
End Sub
Thanks
Maybe try something like this:
Sub Replanning_Lasers()
Dim wsList As Worksheet, wsPlan As Worksheet, rngData As Range, rngBlanks As Range
Set wsList = ThisWorkbook.Sheets("List") 'Use variables for worksheets
Set wsPlan = ThisWorkbook.Sheets("Planning") ' to avoid repetition
Set rngData = wsList.Range("B4:BN1533")
rngData.AutoFilter Field:=3, Criteria1:="LASER"
On Error Resume Next 'ignore error if no visible blank cells
'find any visible blank cells in ColN of the filtered data
Set rngBlanks = rngData.EntireRow.Columns("N"). _
SpecialCells(xlCellTypeVisible). _
SpecialCells(xlCellTypeBlanks)
On Error GoTo 0 'stop ignoring errors
If rngBlanks Is Nothing Then Exit Sub 'no visible blanks
For Each c In rngBlanks.Cells 'process each blank cell in turn
If Sheet25.Range("C14") > Sheet25.Range("D14") Then
Msgbox "supply breach"
Exit For 'Orderbook > Supply ?
End If
wsPlan.Range("C9").Value = c.EntireRow.Columns("I").Value 'no need for copy/pastespecial
BUT_Planning_reset 'use of Call is deprecated...
BUT_Planning_Find_First
c.EntireRow.Columns("N").Value = wsPlan.Range("M9").Value
Next c
End Sub
First off I am not a coder. I am trying to get a section of this code to increment the column number each time the macro is run. It works the first time then has the Range class error the next run. Also my incrementing doesn't appear to be working either. Here is the complete code with the section giving the error pointed out:
Sub Prep_Report_Rev_B()
'
' Prep_Report_Rev_B Macro
'
' Keyboard Shortcut: Ctrl+g
'
' Declare Variables
Dim xdate As Date
Dim incCol As Integer
' Ensure button not pressed multiple times a day
xdate = Worksheets("Summary").Range("F6")
If Month(Date) = Month(xdate) And Year(Date) = Year(xdate) And Day(Date) = Day(xdate) Then
MsgBox "Report can only be run once per day to prevent data loss"
GoTo Line1
End If
' Copy Data to Historical Tab
' ** Need to increment column number **
If incCol = 0 Then
incCol = 1
Else
incCol = incCol + 1 '<--increases of 1 each click
End If
ActiveSheet.Unprotect "0000"
Range("L3:L8,L11:L15,L18:L22,L34:L38,L41:L45,L57:L61,L64:L68").Select
Selection.Copy
Sheets("Historical Data").Select
ActiveSheet.Unprotect "0000"
' =========================================================================
Cells(2, incCol).Offset(0, 5).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False ' <----
' ==========================================================================
ActiveSheet.Protect "0000"
' Enter current Date on "Summary" Page
Sheets("Summary").Select
Range("F6") = Format(Date, "mm/dd/yyyy")
ActiveSheet.Protect "0000"
' Clear "Previous Service Report Data" tab
Sheets("Previous Service Report Data").Select
ActiveSheet.Unprotect "0000"
Cells.Select
Selection.ClearContents
' Copy data from "Service Report" to "Previous Service Report"
Sheets("Service Report Data").Select
ActiveSheet.Unprotect "0000"
Columns("A:AK").Select
Selection.Copy
Sheets("Previous Service Report Data").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Protect "0000"
' Clear "Service Report Data" to prepare for new data
Sheets("Service Report Data").Select
Columns("A:AI").Select
Selection.ClearContents
Range("A1").Select
ActiveSheet.Protect "0000"
' Pull Up webpage
ActiveWorkbook.FollowHyperlink _
Address:="google.com"
Line1:
End Sub
Any help or suggestions would be greatly appreciated.
Here try this, it will move the selected range into a new range. This code should select your range and move it to the Historical Data Sheet. Make sure to change the name on set sh = wb.Sheets("NAME OF YOUR SHEET") to the name of your sheet. I would probably create a test sheet for both to test them to make sure they are doing what you want them to do and you don't mess up your data.
Dim sh As worksheet
Dim sh1 As worksheet
Dim rng, rng1, rng2, rng3, rng4, rng5, rng6 As range
set wb = ThisWorkbook
set sh = wb.Sheets("NAME OF YOUR SHEET")
set sh1 = wb.Sheets("NAME OF SHEET YOU WANT TO COPY TO")
set rng = sh.Range("L3:L8")
set rng1 = sh.Range("L11:L15")
set rng2 = sh.Range("L18:L22")
set rng3 = sh.Range("L34:L38")
set rng4 = sh.Range("L41:L45")
set rng5 = sh.range("L57:L61")
set rng6 = sh.range("L64:L68")
sh1.Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Cells.Value = rng.Cells.Value
sh1.range("B1").Resize(rng1.Rows.Count, rng1.Columns.Count).Cells.Value = rng1.Cells.Value
sh1.range("C1").Resize(rng2.Rows.Count, rng2.Columns.Count).Cells.Value = rng2.Cells.Value
sh1.range("D1").Resize(rng3.Rows.Count, rng3.Columns.Count).Cells.Value = rng3.Cells.Value
sh1.range("E1").Resize(rng4.Rows.Count, rng4.Columns.Count).Cells.Value = rng4.Cells.Value
sh1.range("F1").Resize(rng5.Rows.Count, rng5.Columns.Count).Cells.Value = rng5.Cells.Value
sh1.range("G1").Resize(rng6.Rows.Count, rng6.Columns.Count).Cells.Value = rng6.Cells.Value
Edit - I kind of spelled it out for you in hope if you need to make changes its easy to see what the code is doing, there is probably a better way to do this with less code but this way you are not using copy and paste it just transfers the data and is much faster. I set each range to the first row in each column. To change where you the data is placed just change the location after the sh1.range("G1")
I have the following loop to create multiple tabs in Excel 2016 based on a list of PO#'s. ( see code below)
Sub CreateSheetsFromAList()
Dim MyRange As Range
Dim dic As Object, c As Range
Dim k As Variant, tmp As String
Set dic = CreateObject("scripting.dictionary")
Set MyRange = Sheets("Instructions").Range("h6")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Sheets("Template").Visible = True
For Each c In MyRange
tmp = Trim(c.Value)
If Len(tmp) > 0 Then dic(tmp) = dic(tmp) + 1
Next c
For Each k In dic.keys
If Not WorksheetExists(k) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = k
End If
Next k
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function
I also need to populate each newly created tab with info from another workbook (EDI PO Consolidated - 2018.xlsx)
(see code below)
Sub BandB2()
' BandB2 Macro
' Keyboard Shortcut: Ctrl+b
'
Application.Goto Reference:="R20C10"
Selection.Copy
Windows("EDI PO Consolidated - 2018.xlsx").Activate
ActiveSheet.Range("$A$1:$X$2628").AutoFilter Field:=2, Criteria1:= _
"34535453"
Application.Goto Reference:="R1C9"
Range("I2058").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("J26").Select
ActiveSheet.Paste
Windows("EDI PO Consolidated - 2018.xlsx").Activate
ActiveWindow.SmallScroll ToRight:=4
Application.Goto Reference:="R1C17"
Range("Q2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
ActiveWindow.SmallScroll Down:=6
Range("C33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("EDI PO Consolidated - 2018.xlsx").Activate
Application.Goto Reference:="R1C14"
Range("N2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("D33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("EDI PO Consolidated - 2018.xlsx").Activate
Application.Goto Reference:="R1C18"
Range("R2058:T2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("E33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
I have 2 questions:
1) i cannot make the sheet reference change for each tab; it always picks the
1st po# "34535453"
2) Can you help me combine these into 1 macro.
thank you in advance for your help
Here's a cleaner way to create those tabs.
Name cell H6 on the Instructions tab "PO_Start" or some other appropriate name. That way if you can insert rows or columns on the tab without possibly having to change the reference to H6 in your code.
Sub Create_Sheets()
Dim PO_list, PO As Range
Set PO_list = Range(Sheets("Instructions").Range("PO_Start"), Sheets("Instructions").Range("PO_Start").End(xlDown))
Sheets("Template").Visible = True
For Each PO In PO_list
If Not WorksheetExists(PO) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = PO
End If
Next PO
End Sub
1) To loop through your tabs, if you know that your PO tabs will always start on tab 3, you can loop through the sheets like this (including variable declarations):
Sub B_and_B()
Dim ws As Worksheet
Dim i As Integer
For i = 3 To Sheets.Count
Set ws = Sheets(i)
'... rest of code here
Next i
End Sub
Otherwise if down the road you anticipate adding other sheets besides "Instructions" and "Template" to your Book and Bill file, you could loop through all sheets, error checking to see if you can convert the sheet name to a "long" variable type with Clng(). Probably more than what's needed for your current project.
Another tip:
Avoid using hard-coded cell addresses ("N2058") in your code. If you filter on purchase orders in the Consolidated book and then pull in certain data elements, you'll need to find the row the Purchase Order is in (2058 in this case).
2) To combine these into one macro, you can create a Main subroutine, calling each step separately:
Sub Main()
Call Create_Sheets
Call B_and_B
End Sub
To be short and sweet with my requirement, I need a code to do the conditions below.
Select from range A2:G5
Then check if a sheet named with current date i:e 29-02-2016
If yes,
then copy paste the range in A1 leave 3 rows below for the next data to be pasted below that.
If no,
create a new sheet and name it with current date and then copy paste the range in A1 leave 3 rows below for the next data to be pasted below that.
I tried the below code but it give me error once the current date sheet is created.
Sub Macro1()
Sheets("Sheet1").Select
Range("D3:G12").Select
Selection.Copy
sheets = "todaysdate".select
Dim todaysdate As String
todaysdate = Format(Date, "dd-mm-yyyy")
AddNew:
Sheets.Add , Worksheets(Worksheets.Count)
ActiveSheet.Name = todaysdate
On Error GoTo AddNew
Sheets(todaysdate).Select
Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(3, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
Try these modifications.
Sub Macro1()
Dim todaysdate As String
With Worksheets("Sheet1")
.Range("D3:G12").Copy
End With
todaysdate = Format(Date, "dd-mm-yyyy")
On Error GoTo AddNew
With Worksheets(todaysdate)
On Error GoTo 0
With .Cells(Rows.Count, "A").End(xlUp).Offset(3, 0)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End With
Exit Sub
AddNew:
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = todaysdate
With .Cells(Rows.Count, "A").End(xlUp)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End With
End Sub
Step through the modified procedure with the [F8] key to watch how it handles the thrown error and continues on to exit or processes the paste with a three row offset.
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