I'm trying to write a macro that copies tables (colors, formats etc.) from the sheet for each day (Monday, Tuesday, Wednesday, Thursday and Friday) and pastes to sheets (262 sheets) for the same day. (Monday - Monday etc.) Sheets names I have in sheet "Data".
But I got this error:
Run-time error '1004': Method PasteSpecial class Range Failure.
This is my VBA macro:
Sub copy_paste()
For i = 1 To 262
If 1 = i Mod 5 Then
Worksheets("wednesday").Activate
Cells.Select
Application.CutCopyMode = False
Selection.Copy
' This is the problem part of code (said Debugger)
Sheets(Worksheets("Data").Cells(i, 2).Value).Range("A1").PasteSpecial _
Paste:=x1PasteAllUsingSourceTheme, Operation:=x1None _
, SkipBlanks:=False, Transpose:=False
End If
If 2 = i Mod 5 Then
Sheets("thursday").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Worksheets("Data").Cells(i, 2).Value).Range("A1").PasteSpecial _
Paste:=x1PasteAllUsingSourceTheme, Operation:=x1None _
, SkipBlanks:=False, Transpose:=False
End If
If 3 = i Mod 5 Then
Sheets("friday").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Worksheets("Data").Cells(i, 2).Value).Range("A1").PasteSpecial _
Paste:=x1PasteAllUsingSourceTheme, Operation:=x1None _
, SkipBlanks:=False, Transpose:=False
End If
If 4 = i Mod 5 Then
Sheets("monday").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Worksheets("Data").Cells(i, 2).Value).Range("A1").PasteSpecial _
Paste:=x1PasteAllUsingSourceTheme, Operation:=x1None _
, SkipBlanks:=False, Transpose:=False
End If
If 0 = i Mod 5 Then
Sheets("tuesday").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Worksheets("Data").Cells(i, 2).Value).Range("A1").PasteSpecial _
Paste:=x1PasteAllUsingSourceTheme, Operation:=x1None _
, SkipBlanks:=False, Transpose:=False
End If
Next i
End Sub
You can use the Worksheets("SheetName").Paste method, instead of the Range.PasteSpecial method.
But really, I'd recommend using a full up worksheet copy if you're literally copying everything:
Worksheets("wednesday").Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = Worksheets("Data").Cells(i, 2).Value
After I fixed these two issues, it works.
You have x1 everywhere in your code instead of xl.
– Justyna MK
please check whether it should be Operation:=xlPasteSpecialOperationNone instead of Operation:=x1None
– skkakkar
Related
I am trying to write a code that it filters out by production day.
It then filters for the different lines (field 3) (Line A/B, Line C, etc)
and it then takes the item numbers for those and pastes it into another sheet.
However, now when I change the day criteria to another day - for example day 6...
not all the lines which existed in Day 1 exist.
So if I replace field 1, criteria one with 6 instead of 1, it messes up the sheet because Line A/B does not exist for Day 6.
how can i tweak this code so that even if that specific line filter does not exist for a certain day - it ignores or doesn't mess up the rest of the sheet.
Any help would be greatly appreciated!
Range("D7:O7").Select
Selection.AutoFilter
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=10, Criteria1:=Array( _
"1,120.67", "1,200.00", "10,472.00", "121.00", "185.00", "190.50", "24.00", "241.50", _
"30.00", "436.00", "450.00", "465.00", "500.00", "525.00", "54.00", "60.00", "630.00", _
"71.00", "756.00", "893.00", "90.00", "984.50", "991.00"), Operator:= _
xlFilterValues
ActiveWindow.ScrollColumn = 1
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=1, Criteria1:="1"
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=3, Criteria1:="A/B"
Range("E8:E52").Select
Selection.Copy
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Production Schedule - Daily").Select
Range("I12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("July Production for Open Orders").Select
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=3, Criteria1:="=B/C", _
Operator:=xlOr, Criteria2:="=Line B"
Range("E8:E52").Select
Application.CutCopyMode = False
Selection.Copy
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Production Schedule - Daily").Select
Range("U12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("July Production for Open Orders").Select
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=3, Criteria1:="Line C"
Range("E8:E52").Select
Application.CutCopyMode = False
Selection.Copy
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Production Schedule - Daily").Select
Range("AG12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("July Production for Open Orders").Select
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=3, Criteria1:="Line O"
Range("E8:E52").Select
Application.CutCopyMode = False
Selection.Copy
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Production Schedule - Daily").Select
Range("AS12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("July Production for Open Orders").Select
ActiveSheet.ShowAllData
Sheets("Production Schedule - Daily").Select
Range("E1").Select
You can improve your code by using some variables to refer to the sheets and ranges you're using, and by extracting the "copy and paste visible cells only" steps to a separate Sub which you can call from your main code. Use some error handling to take care of cases where all rows are filtered and there are no visible cells to copy.
Sub Tester()
Dim rngTable As Range, rngHdrs As Range, rngCopy As Range, ws As Worksheet
Dim rngVis As Range, wsPS As Worksheet
Set ws = ActiveSheet 'source sheet
Set wsPS = ws.Parent.Worksheets("Production Schedule - Daily")
Set rngTable = ws.Range("D7:O52") 'whole table
Set rngHdrs = rngTable.Rows(1) 'headers
Set rngCopy = rngTable.Columns(2).Offset(1, 0). _
Resize(rngTable.Rows.Count - 1) 'Col E, data only
rngHdrs.AutoFilter
rngTable.AutoFilter Field:=10, Criteria1:=Array( _
"1,120.67", "1,200.00", "10,472.00", "121.00", "185.00", "190.50", "24.00", "241.50", _
"30.00", "436.00", "450.00", "465.00", "500.00", "525.00", "54.00", "60.00", "630.00", _
"71.00", "756.00", "893.00", "90.00", "984.50", "991.00"), Operator:= _
xlFilterValues
rngTable.AutoFilter Field:=1, Criteria1:="1"
rngTable.AutoFilter Field:=3, Criteria1:="A/B"
CopyVisible rngCopy, wsPS.Range("I12")
rngTable.AutoFilter Field:=3, Criteria1:="=B/C", Operator:=xlOr, Criteria2:="=Line B"
CopyVisible rngCopy, wsPS.Range("U12")
rngTable.AutoFilter Field:=3, Criteria1:="Line C"
CopyVisible rngCopy, wsPS.Range("U12")
rngTable.AutoFilter Field:=3, Criteria1:="Line O"
CopyVisible rngCopy, wsPS.Range("AS12")
ws.ShowAllData
wsPS.Select
wsPS.Range("E1").Select
End Sub
'copy all visible cells from `rngFrom` and paste as values to `rngTo`
' Return False if no visible cells were found
Sub CopyVisible(rngFrom As Range, rngTo As Range)
Dim vis As Range
On Error Resume Next 'ignore error if no cells found
Set vis = rngFrom.SpecialCells(xlCellTypeVisible)
On Error GoTo 0 'stop ignoring errors
If Not vis Is Nothing Then
vis.Copy
rngTo.Cells(1).PasteSpecial Paste:=xlPasteValues
End If
End Sub
My file has four sheets.
From all of them, I want to copy and paste column A (from A:10) (which contains a concat formula) when some other rows are populated and then save into a csv.
All rows from A10 onwards have the concat formula which is then filled in depending on the other columns (the same applies for the other sheets).
I have it currently creating sheet1, and pasting there, then saving as a csv.
However, from the first sheet it looks at, it takes only the first line (but the second line - J11 (and so A11) are populated.
In the other sheets, it is copy and pasting the 2 rows that are populated, but also all the other rows as there are formulas there that return zero.
As I have the .End(xlDown) and technically all the other rows are populated.
I tried an IF statement for the last sheet only as a test, and currently it only copies the first populated line, and not the second (but at least it also doesn't copy all the other cells with zero).
Essentially, for each sheet I'd like to loop through with for example E10 is populated, copy and paste A10 into Sheet1, etc., if E10 is not zero.
Sub Output_test1()
'
' Output_test1 Macro
'
'
Sheets("Create").Select
Range("A10", Range("J10").End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets.Add.Name = "Sheet1"
Sheets("Sheet1").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Assign").Select
Range("A10", Range("E10").End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("A1").End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Date & Time").Select
Range("A10", Range("E10").End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("A1").End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Event Type").Select
Dim rg As Range
For Each rg In Range("E10").End(xlDown)
If rg.Value > 0 Then
End If
Range("A10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("A1").End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
Application.CutCopyMode = False
Next
Sheets("Sheet1").Move
myTime = Format(Now, ("dd.mm.yy"))
ChDir "C:\Users\"
ActiveWorkbook.SaveAs Filename:= _
"Recruit_" & myTime & ".csv", FileFormat:=xlCSVUTF8, _
CreateBackup:=False
End Sub
There is no loop in your code not are you checking any values. I assumed you need to check column J in the source sheet and copy column A to the destination sheet.
This is a possible starting point:
k = 1
For i = 10 to 20
If Sheets("Source").Range("J" & i).Value = 0 then
Sheets("Destination").Range("A" & k).Value = Sheets("Source").Range("A" & i).Value
k = k + 1
End if
Next i
This only copies the value, not the formula. Not sure how much to explain, comment on the answer if any questions
Sub vova()
Dim S_path As String
Dim S_name1 As String, S_nameW1 As String
S_path = "S:\"
S_path = Trim(S_path) + Trim(Worksheets("1").Range("G6").Value) + ".xlsx"
Range("A1:N27").Select
Selection.Copy
Workbooks.Add
S_nameW1 = ActiveWorkbook.name
S_name1 = ActiveSheet.name
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Columns("A:A").ColumnWidth = 2
Columns("B:B").ColumnWidth = 10
Columns("C:C").ColumnWidth = 35
Columns("D:D").ColumnWidth = 13
Columns("M:M").ColumnWidth = 15
Columns("N:N").ColumnWidth = 15
Application.CutCopyMode = False
ActiveWorkbook.SaveAs FileName:=S_path, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
End Sub
Can someone help me, need the macro to delete blank raws(if 1-5 is filled) then 6-15 is deleted and macro creates new workbook with needed raws
created workbook should look like this
You could do something like that:
Columns("N:N").ColumnWidth = 15
Application.CutCopyMode = False
With S_name1
for i = .range("A1048576").end(xlup).row to 9 Step -1
if .cells(i, 2) = "" Then
.rows(i & ":" & i).delete
End if
Next
End With
ActiveWorkbook.SaveAs FileName:=S_path, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
This will basically loop backward from the last used cell in column A till row 9, and delete the row if there is nothing in column B (which appears to be the case in your screenshot).
I'm creating a button that will allow the user to add a new record to the very top of the list, and move all records one row below (to keep the newest records at the top). The code I've written works perfectly as-is. However, I have to write a lot of repeating code to apply it to all rows within the range. Here is my code:
Sub Test2()
' Stop screen from following macro actions & disable alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' If more than 1 record, copy all rows and paste 1 row below, apply merged cell formatting, clear data from first row, and re-enable alerts/screen updating
If WorksheetFunction.CountA(Range("AM5:AN21")) > 1 Then
Range("CW28:DJ28").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("CW29:DJ29").Select
ActiveSheet.Paste
Range("CW28:DJ28").Select
Selection.Copy
Range("CW29").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
...
Range("CW1277").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("CW28:DJ28").Select
Selection.ClearContents
Range("CW28:CX28").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' If only 1 record, copy first row and paste 1 row below, apply merged cell formatting, clear data from first row, and re-enable alerts/screen updating
ElseIf WorksheetFunction.CountA(Range("AM5:AN21")) = 1 Then
Range("CW28:DJ28").Select
Selection.Copy
Range("CW29:DJ29").Select
ActiveSheet.Paste
Range("CW28:DJ28").Select
Selection.Copy
Range("CW29").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
...
Range("CW1277").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("CW28:DJ28").Select
Selection.ClearContents
Range("CW28:CX28").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' If zero records, re-enable alerts/screen updating
Else
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
End Sub
As you can see, the two spots where the "..." I need to apply to rows 29 through 1277. I know there's got to be a better way to do this with For ... Next, but what I've tried hasn't worked (code that I used is below, it would give me an error saying I can't do that to merged cells, even though my current code works).
Dim rng As Range: Set rng = Application.Range("CW28:CX1277")
Dim i As Integer
For i = 1 To 1248
rng.Cells(RowIndex:=i, ColumnIndex:="CW").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next
I know my entire issue is that we have merged cells, but we need to keep them if at all possible. Knowing that my current, repetitive coding works... is there a way to make the For ... Next function work?
What I understand of your code is that you copy the format of line N to line N+1 for columns CW to DJ, from lines 28 to 1277, by block.
(I strongly suppose it is not as much simple).
What you could do is (I replace your 28 by beginRow) :
dim beginRow as long, endRow as long
dim strRange as string
beginRow=28
while (beginRow<<1277)
strRange = "CW" & beginRow & ":DJ" & beginRow
Range(strRange).select
endRow=Selection.End(xlDown).row
strRange = "CW" & beginRow & ":DJ" & endRow
Range(strRange).Copy
strRange = "CW" & (beginRow+1) & ":DJ" & (endRow+1)
Range(strRange).Select
ActiveSheet.Paste
strRange = "CW" & (beginRow) & ":DJ" & (beginRow+1)
Range(strRange).Copy
Range("CW" & (beginRow+1)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
' find next block
beginRow=Range("CW" & (endRow+1)).End(xlDown).row
wend
Could this help ?
Pierre.
I figured it out!
Dim rng As Range
Dim cell As Range
Range("CW28:DJ28").Select
Selection.Copy
Set rng = Range("CW29:1277")
For Each cell In rng.Cells
cell.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next cell
Application.CutCopyMode = False
Now, I need to focus on how to get rid of .Select and .Activate throughout my code. Thank you so much for your help, all!
Good day,
I could only find examples where the tables are quite simple and the data minimal. I'm sitting with 36 makes, and up to 3 072 variants on the below data which I need sorted out.
The below col A through E is an extract of my data, with col G through I, the selections I need to make. To explain.
Blockquote
Col G: Should be a drop down with the values from Col C (which is easy and is done already)
Blockquote
Col H: If I now select Abarth in Col G, I only want the 500/695 or 124 displayed in a drop down, where I will choose 124
Blockquote
Col I: Similar to Col H, now only Abarth 124 related items should be displayed in the drop down
SOLVED! I have written macros to resolve as follows:
Sub SelectModel()
'
' SelecModel Macro
'
'
ActiveCell.Select
' Save the active cell to use later
Set myActiveCell = ActiveCell
Set myActiveWorksheet = ActiveSheet
Set myActiveWorkbook = ActiveWorkbook
ActiveCell.Copy Destination:=Sheets("2018MMCodes").Range("AU1")
Sheets("2018MMCodes").Select
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Columns("AV:AX").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Selections").Select
Range("A1").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$C$3257").RemoveDuplicates Columns:=2, Header:= _
xlYes
'Returns the user to the original sheet to enable just making a selection
myActiveWorkbook.Activate
myActiveWorksheet.Activate
myActiveCell.Activate
End Sub
Sub SelectVariant()
'
' SelectVariant Macro
'
'
ActiveCell.Select
' Save the active cell to use later
Set myActiveCell = ActiveCell
Set myActiveWorksheet = ActiveSheet
Set myActiveWorkbook = ActiveWorkbook
Selection.Copy
Sheets("2018MMCodes").Select
Range("AU3").Select
ActiveSheet.Paste
Columns("AV:AX").Select
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
Range("AV1:AX3257").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("'2018MMCodes'!Criteria"), Unique:=False
Selection.Copy
Sheets("Selections").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Returns the user to the original sheet to enable just making a selection
myActiveWorkbook.Activate
myActiveWorksheet.Activate
myActiveCell.Activate
End Sub