I am trying to write a macro that takes parts of one sheet and paste values on the next. I know using select isn't ideal. But i Don't know how to do it other wise. In the past i have got a out of range error if i was not selecting the sheet before hand. In the macro i have y defined earlier but I am getting an
1004 application-defined or object-defined error
y = Sheets("sheet1").Range("B1", Range("B2").End(xlDown)).Count
Sheets("Bucket12").Select
Sheets("Bucket12").Range("C2", Range("C2").End(xlDown)).Copy
Sheets("upload").Range(Cells(y, 2)).PasteSpecial xlPasteValues
Sheets("Bucket12").Range("E2", Range("E2").End(xlDown)).Copy
Sheets("upload").Range(Cells(y, 3)).PasteSpecial xlPasteValues
Sheets("Bucket12").Range("G2", Range("G2").End(xlDown)).Copy
Sheets("upload").Range(Cells(y, 5)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
The issue is that Range() expects two arguments - Cell1 and Cell2 - you're only giving it one argument, which is throwing error 1004.
Instead, just use .Cells():
y = Sheets("sheet1").Range("B1", Range("B2").End(xlDown)).Count
Sheets("Bucket12").Select
Sheets("Bucket12").Range("C2", Range("C2").End(xlDown)).Copy
Sheets("upload").Cells(y, 2).PasteSpecial xlPasteValues
Sheets("Bucket12").Range("E2", Range("E2").End(xlDown)).Copy
Sheets("upload").Cells(y, 3).PasteSpecial xlPasteValues
Sheets("Bucket12").Range("G2", Range("G2").End(xlDown)).Copy
Sheets("upload").Cells(y, 5).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Better yet, let's avoid Select, Copy and Paste altogether:
y = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, 2).End(xlUp).Row
Dim sht1 As Worksheet, sht2 As Worksheet, lastrow As Long
Set sht1 = ThisWorkbook.Worksheets("Bucket12")
Set sht2 = ThisWorkbook.Worksheets("upload")
lastrow = sht1.Cells(sht1.Rows.Count, 3).End(xlUp).Row
sht2.Range(sht2.Cells(y, 2), sht2.Cells(lastrow + y - 2, 2)).Value = _
sht1.Range(sht1.Cells(2, 3), sht1.Cells(lastrow, 3)).Value
lastrow = sht1.Cells(sht1.Rows.Count, 5).End(xlUp).Row
sht2.Range(sht2.Cells(y, 3), sht2.Cells(lastrow + y - 2, 3)).Value = _
sht1.Range(sht1.Cells(2, 5), sht1.Cells(lastrow, 5)).Value
lastrow = sht1.Cells(sht1.Rows.Count, 7).End(xlUp).Row
sht2.Range(sht2.Cells(y, 5), sht2.Cells(lastrow + y - 2, 5)).Value = _
sht1.Range(sht1.Cells(2, 7), sht1.Cells(lastrow, 7)).Value
As another note - it's better to use xlUp than xlDown when determining your lastrow for data entry.
Related
VBA novice and got 90% of the way to what I need but I just can't figure out the final part. For the last step I have a range of data from A:K, with A containing a unique number. An updated version of this data is pasted below the initial range with the numbers in Column A staying the same, but B:K being updated.
How can i copy the duplicate row below, paste it over the original above, and then delete the duplicate?
Sub TEST2()
'
' TEST2 Macro
'
' Sheets("Sheet1").Select
ActiveSheet.Range("A1:K1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$L$20").AutoFilter Field:=8, Criteria1:="red"
Range("a2").Select
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:K" & LR).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A2").Select
Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveSheet.Range("A1:l100").RemoveDuplicates Columns:=Array(1, 1), Header:=xlYes
End With
Range("$q$1").Select
Selection.Copy
Range("H2:H1000").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("Sheet1").Select
Worksheets("Sheet1").ShowAllData
Range("O3").Select
Sheets("Sheet2").Select
Range("O3").Select
End Sub
At the moment i can only get as far as using this to delete the duplicates. There are other elements to the sheet which require it to be done this way.
Thanks in advance for any help!!
First thought after seeing the issue... it's a little more than a single line:
Dim i as integer, LR as Long
LR = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 to LR 'Assumes that row 1 is headers
If Application.Match(Cells(i,1),Range(Cells(2,1),Cells(i-1,1)),0)>0 Then
Rows(i).Cut
Rows(Application.Match(Cells(i,1),Range(Cells(2,1),Cells(i-1,1)),0)+1).PasteSpecial xlPasteValues
Else
End If
Next i
Edit: It's not liking the range; I will try cleaning it up, then use insert/delete... keep in mind, if we're using delete for any row, you'll want to reverse the step, as to avoid issues. See below changes, noting that j is added:
Dim i As Integer, j As Integer, LR As Long
LR = Cells(Rows.Count, "A").End(xlUp).Row
For i = LR To 3 Step -1 'Assumes that row 1 is headers
If Application.IfError(Application.Match(Cells(i, 1), Range(Cells(2, 1), Cells(i - 1, 1)), 0), 0) > 0 Then
j = Application.Match(Cells(i, 1), Range(Cells(2, 1), Cells(i - 1, 1)), 0)
Range(Cells(i, 1), Cells(i, 11)).Cut
Range(Cells(j + 1, 1), Cells(j + 1, 11)).Insert xlShiftDown
Range(Cells(j + 2, 1), Cells(j + 2, 11)).Delete
End If
Next i
You can use the below algorithm (with illustrated example as below) :-
Create a column to store sequential number for sorting purpose
Perform the sorting so that the latest appended rows are always at the top. Excel's removeduplication function will always keep the first encountered unique value
Once done, you can perform sorting to re-order the rows of data again.
Below is a sample code which you will need to modify based on your actual dataset.
Sub Test()
LastRow = Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
Range("L1").Value = LastRow
Range("L2").Value = LastRow - 1
Range("L1:L2").AutoFill Destination:=Range("L1:L" & LastRow)
Range("A1:L" & LastRow).Sort Order1:=xlAscending, Key1:=Range("L1"), Header:=xlNo
Range("A1:L" & LastRow).RemoveDuplicates Columns:=Array(1, 1), Header:=xlNo
End Sub
So following the prious question (VBA migrating data from different worksheets to one worksheet at specific locations) I have edited the code to the following below based on posts from other code researchers/experts.
The previous codes (see link) were working up to a certain point where a running time error would come up. I have followed the suggestions and removed .Select. and .Activate from the copy/paste operations however currently the code below does not do anything from the point 'copy from feedstock records sheet' onwards. I am sure I am doing something wrong or that I could approach my problem in a different way but I am struggling to find a solution. Does anyone have any ideas?
After debugging I have managed to overcome the error 13 which was related to cells though defined as date the order of date was messed up and once I changed the order of the cells it was ok. However I know have the error 1004 as decribed in the comments below (see my last comment). I was wondering if anyone has any approche on how to solve this issue. I have marked where the error appears (it's on the second loop). in sht5 the date only starts on 01/01/2015 however sht4 starts on 07/08/2014. After I fixed the problem on the first days in 2014 the code was able to run until it reached the value 01/01/2015 when past special the range specified in bold below. Could anyone help? Thanks
Option Explicit
Sub main()
'open/close worksheets from huddle folder and teamviewer'
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim Wb3 As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim sht4 As Worksheet
Dim sht5 As Worksheet
Dim i As Long, j As Long, k As Long, lastrow1 As Long, lastrow2 As Long, lastrow3 As Long
Dim monthsi As Date, monthsk As Date, monthsj As Date
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set Wb1 = Workbooks.Open("U:\Data from plants\Huddle\EEL Feedstock Records - NEW VERSION.xlsx")
Set Wb2 = Workbooks.Open("U:\Data from plants\Teamviewer\EE.xlsx")
Set Wb3 = ThisWorkbook
Set sht1 = Wb1.Sheets("Feedstock Usage (Non-beet site)")
Set sht2 = Wb2.Sheets("Sheet1")
Set sht3 = Wb3.Sheets("Feedstock records")
Set sht4 = Wb3.Sheets("Teamviewer")
Set sht5 = Wb3.Sheets("Plants data")
sht3.Cells.Delete Shift:=xlUp
sht4.Cells.Delete Shift:=xlUp
sht1.Cells.Copy
sht3.Range("A1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
Wb1.Close False
sht2.Cells.Copy
sht4.Range("A1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
Wb2.Close False
'copy from feedstock records sheet'
lastrow1 = sht3.Range("C" & Rows.Count).End(xlUp).Row
i = 10
lastrow2 = sht4.Range("A" & Rows.Count).End(xlUp).Row
k = 4
lastrow3 = sht5.Range("A" & Rows.Count).End(xlUp).Row
j = 5
Do
monthsi = sht3.Cells(i, "C").Value
If sht5.Cells(j, "A").Value = monthsi Then
sht3.Range(Cells(i, "D"), Cells(i, "E")).Copy
sht5.Range(Cells(j, "VE"), Cells(j, "VF")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "G"), Cells(i, "H")).Copy
sht5.Range(Cells(j, "VI"), Cells(j, "VJ")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "J"), Cells(i, "K")).Copy
sht5.Range(Cells(j, "VM"), Cells(j, "VN")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "M"), Cells(i, "N")).Copy
sht5.Range(Cells(j, "VY"), Cells(j, "VZ")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "P"), Cells(i, "Q")).Copy
sht5.Range(Cells(j, "VQ"), Cells(j, "VR")).PasteSpecial xlPasteValues
End If
i = i + 1
Loop Until i = lastrow1 + 1
Do
monthsk = sht4.Cells(k, "A").Value
If sht5.Cells(j, "A").Value = monthsk Then
sht4.Cells(k, "H").Copy
sht5.Cells(j, "XW").PasteSpecial xlPasteValues
sht4.Cells(k, "I").Copy
sht5.Cells(j, "YJ").PasteSpecial xlPasteValues
sht4.Range(Cells(k, "J"), Cells(k, "O")).Copy
**sht5.Range(Cells(j, "ZK"), Cells(j, "ZP")).PasteSpecial xlPasteValues**
sht4.Cells(k, "U").Copy
sht5.Cells(j, "XU").PasteSpecial xlPasteValues
sht4.Cells(k, "X").Copy
sht5.Cells(j, "XV").PasteSpecial xlPasteValues
sht4.Cells(k, "Y").Copy
sht5.Cells(j, "YH").PasteSpecial xlPasteValues
sht4.Cells(k, "AB").Copy
sht5.Cells(j, "YI").PasteSpecial xlPasteValues
sht4.Range(Cells(k, "AN"), Cells(i, "AP")).Copy
sht5.Range(Cells(j, "XR"), Cells(j, "XT")).PasteSpecial xlPasteValues
sht4.Cells(k, "AQ").Copy
sht5.Cells(j, "XQ").PasteSpecial xlPasteValues
End If
k = k + 1
Loop Until k = lastrow2 + 1
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
It looks like you may want to bring the setting of monthsi, monthsj and monthsk inside your loops. You increase i in the first loop for example, but that doesn't change monthsi, so if the comparison is false to begin with, the if statement will never run.
For example, the first loop would become:
Do
monthsi = sht3.Cells(i, "C").Value
If monthsj = monthsi Then
sht3.Range(Cells(i, "D"), Cells(i, "E")).Copy
sht5.Range(Cells(j, "VA"), Cells(j, "VB")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "G"), Cells(i, "H")).Copy
sht5.Range(Cells(j, "VE"), Cells(j, "VF")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "J"), Cells(i, "K")).Copy
sht5.Range(Cells(j, "VI"), Cells(j, "VJ")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "M"), Cells(i, "N")).Copy
sht5.Range(Cells(j, "VM"), Cells(j, "VN")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "P"), Cells(i, "Q")).Copy
sht5.Range(Cells(j, "VQ"), Cells(j, "VR")).PasteSpecial xlPasteValues
End If
i = i + 1
Loop Until i = lastrow1 + 1 Or j = lastrow3 + 1
This still leaves the question raised by PartyHatPanda of why you are checking against j to end the loop when j isn't changing, so there may be a deeper error in your logic. ie if j should be increasing as well, then the assignment of monthsj should also be brought into the loop in the same way.
I have a macro that copies some columns from a BD Sheet and pastes in another sheet.
I've got this code working in Excel 2007, but I've encountered an issue Selecting a Sheet, then copy/paste in Excel 2010 and later. It seems the problem is not in my .Select. It appears to be in the PasteSpecial() that automatically selects the with Sheet() and executes other .copy() without going back to de previous sheet (the screen blinks every pasteSpecial) - I don't know if I was clear enough. [sometimes it works fine, especially using debugger]
Code
Const BD_SHEET As String = "Estrategia"
Const PRICE_SHEET As String = "Precos"
Public Sub Execute()
....
actualCalculate = Application.Calculation
Application.Calculation = xlCalculationManual
LoadPrices()
Application.Calculate
Application.Calculation = actualCalculate
End Sub
Private Sub LoadPrices()
Dim lastSheet As Worksheet
Set lastSheet = ActiveSheet
Sheets(BD_SHEET).Select
lastRow = [A1000000].End(xlUp).row
With Sheets(PRICE_SHEET)
Range(Cells(2, 2), Cells(lastRow, 2)).Copy
.[A2].PasteSpecial xlPasteValues '<---- Working
Range(Cells(2, 7), Cells(lastRow, 7)).Copy
.[B2].PasteSpecial xlPasteValues '<---- Working
Range(Cells(2, 9), Cells(lastRow, 10)).Copy '<---- Error!
.[C2].PasteSpecial xlPasteValues
Range(Cells(2, 12), Cells(lastRow, 12)).Copy '<---- Error!
.[E2].PasteSpecial xlPasteValues
End With
lastSheet.Select
End Sub
I can remove .Select and add Set theSheet = Sheets(BD_SHEET) but the code is going to be durty.
Exemple:
...
Set lastSheet = ActiveSheet
Set bdSheet = Sheets(BD_SHEET)
lastRow = [A1000000].End(xlUp).row
With Sheets(PRICE_SHEET)
bdSheet.Range(bdSheet.Cells(2, 2), bdSheet.Cells(lastRow, 2)).Copy
.[A2].PasteSpecial xlPasteValues
End With
...
but the code is going to be durty.
That is because you are doing it the wrong way
Instead of
With Sheets(PRICE_SHEET)
bdSheet.Range(bdSheet.Cells(2, 2), bdSheet.Cells(lastRow, 2)).Copy
.[A2].PasteSpecial xlPasteValues
End With
Do this
With bdSheet
.Range(.Cells(2, 2), .Cells(lastRow, 2)).Copy
Sheets(PRICE_SHEET).[A2].PasteSpecial xlPasteValues '<---- Working
End With
Also never use Hardcoded values to find the last row. You may see This on how to calculate the last row.
Also
Range1.Copy
Range2.PasteSpecial xlPasteValues
can be written as
Range2.Value = Range1.Value
Applying the above, I have re-written your code. Is this what you are trying? (Untested)
Private Sub LoadPrices()
Dim wsCopyFrm As Worksheet, wsCopyTo As Worksheet
Dim rng As Range
Dim lastRow As Long
Set wsCopyFrm = ThisWorkbook.Sheets(BD_SHEET)
Set wsCopyTo = ThisWorkbook.Sheets(PRICE_SHEET)
With wsCopyFrm
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range(.Cells(2, 2), .Cells(lastRow, 2))
wsCopyTo.Range("A2").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Set rng = .Range(.Cells(2, 7), .Cells(lastRow, 7))
wsCopyTo.Range("B2").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Set rng = .Range(.Cells(2, 9), .Cells(lastRow, 10))
wsCopyTo.Range("C2").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Set rng = .Range(.Cells(2, 12), .Cells(lastRow, 12))
wsCopyTo.Range("E2").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End With
End Sub
Thanks for reading my questions.
I have a table [ws1(A4:Q500)] contains data, while there are formula after column Q. Therefore I cannot copy the whole row but only certain range in text.
Column Q is the formula to define whether the data falls into period, i.e. 16/11-30/11 data. The flag is as follows:
0 < 16/11
1 = 16/11 - 30/11
2 > 30/11
Here the goal is to copy ws1 data with flag "1" to [ws2(A2:P200)]
And then delete ws1 data with flag "1" and "2"
Believe that the rules for copying and deleting is quite similar, I tried to do the copy parts first
Sub PlotGraph()
Dim i As Integer
Dim j As Integer
Dim lastrow As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Data")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Analysis")
j = 2
lastrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To lastrow
If ws1.Cells(i, 17) = 1 Then
ws1.Range(Cells(i, 1), Cells(i, 16)).Copy
ws2.Range(Cells(j, 1), Cells(j, 16)).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=True, _
Transpose:=False
j = j + 1
End If
Next i
End Sub
The debug functions said its wrong in
ws1.Range(Cells(i, 1), Cells(i, 16)).Copy
I tried hard to do modifications but it stills not work, please help me a bit :( Thanks so much.
The ws2.Range(Cells(j, 1), Cells(j, 16)).PasteSpecial does not adequately reference the range as belonging to ws2. The Cells(...) within the range could belong to any worksheet; they have to specifically belong to ws2. The same goes for ws1.
ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 16)).Copy
ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 16)).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=True, _
Transpose:=False
An AutoFilter Method may save you some time with a bulk value transfer.
Sub PlotGraph()
Dim i As Long, j As Long, lr As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Data")
Set ws2 = ThisWorkbook.Sheets("Analysis")
j = 2
With ws1
lr = .Cells(Rows.Count, 1).End(xlUp).Row
With .Range(.Cells(3, 1), .Cells(lr, 17)) 'Range(A3:Q & lr) need header row for autofilter
.AutoFilter field:=17, Criteria1:=1
With .Resize(.Rows.Count - 1, 16).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.Cells.Copy _
Destination:=ws2.Cells(j, 1)
'optional Copy/PasteSpecial xlPasteValues method
'.Cells.Copy
'ws2.Cells(j, 1).PasteSpecial Paste:=xlPasteValues
'▲ might want to locate row j properly instead of just calling it 2
End If
End With
End With
End With
End Sub
I noticed you are using a Range.PasteSpecial method with xlPasteValues. If you require value-only transfer, then that can be accommodated.
This should be simple but I am having a tough time.. I want to copy the cells A3 through E3, and paste them into the next empty row on a different worksheet. I have used this code before in longer strings of code.. but i had to tweak it and it is not working this time. I get a "application-defined or object-defined error" when i run the code seen below. All help is appreciated.
Private Sub CommandButton1_Click()
Dim lastrow As Long
lastrow = Range("A65536").End(xlUp).row
Range("A3:E3").Copy Destination:=Sheets("Summary Info").Range("A:A" & lastrow)
End Sub
Be careful with the "Range(...)" without first qualifying a Worksheet because it will use the currently Active worksheet to make the copy from. It's best to fully qualify both sheets. Please give this a shot (please change "Sheet1" with the copy worksheet):
EDIT: edited for pasting values only based on comments below.
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Sheet2")
copySheet.Range("A3:E3").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
The reason the code isn't working is because lastrow is measured from whatever sheet is currently active, and "A:A500" (or other number) is not a valid range reference.
Private Sub CommandButton1_Click()
Dim lastrow As Long
lastrow = Sheets("Summary Info").Range("A65536").End(xlUp).Row ' or + 1
Range("A3:E3").Copy Destination:=Sheets("Summary Info").Range("A" & lastrow)
End Sub
You could also try this
Private Sub CommandButton1_Click()
Sheets("Sheet1").Range("A3:E3").Copy
Dim lastrow As Long
lastrow = Range("A65536").End(xlUp).Row
Sheets("Summary Info").Activate
Cells(lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub
Below is the code that works well but my values overlap in sheet "Final" everytime the condition of <=11 meets in sheet "Calculator"
I would like you to kindly support me to modify the code so that the cursor should move to next blank cell and values keeps on adding up like a list.
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Calculator")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Final")
For i = 2 To ws1.Range("A65536").End(xlUp).Row
If ws1.Cells(i, 4) <= 11 Then
ws2.Cells(i, 1).Value = Left(Worksheets("Calculator").Cells(i, 1).Value, Len(Worksheets("Calculator").Cells(i, 1).Value) - 0)
ws2.Cells(i, 2) = Application.VLookup(Cells(i, 1), Worksheets("Calculator").Columns("A:D"), 4, False)
ws2.Cells(i, 3) = Application.VLookup(Cells(i, 1), Worksheets("Calculator").Columns("A:E"), 5, False)
ws2.Cells(i, 4) = Application.VLookup(Cells(i, 1), Worksheets("Calculator").Columns("A:B"), 2, False)
ws2.Cells(i, 5) = Application.VLookup(Cells(i, 1), Worksheets("Calculator").Columns("A:C"), 3, False)
End If
Next i