When I run the code below, my range, Master, pastes twice, once with content, and once with empty cells.
Sub AddProj() 'Adds new template to Data Worksheet
Sheet1.Range("Master").Copy
Sheet1.Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlFormats
FindProj
End Sub
When my code is like below, it works properly but doesn't paste formatting:
Sub AddProj() 'Adds new template to Data Worksheet
Sheet1.Range("Master").Copy Sheet1.Range("C" & Rows.Count).End(xlUp).Offset(1)
FindProj
End Sub
FindProj is just some function to copy and paste a cell:
Sub FindProj() 'Finds project name in Historical Worksheet and pastes it in Data Worksheet
Dim Lastrow As Long
Dim Newproj As Long
Dim Master As Range
Dim Masterrow As Long
Masterrow = Worksheets("Data").Range("Master").Rows.Count
Lastrow = Sheets("Historical").Cells(Rows.Count, "B").End(xlUp).Row
Newproj = Sheets("Data").Cells(Rows.Count, "C").End(xlUp).Row
Sheets("Historical").Cells(Lastrow, "B").Copy Sheets("Data").Cells(Newproj - Masterrow + 1, "C")
End Sub
Also, the first code only works once and then never again.
Obviously the PasteSpecial is messing things up but I can't see why. Is there a way to incorporate PasteSpecial into the second code?
Will this help?
Sheet1.Range("Master").Copy
With Sheet1.Range("C" & Rows.Count).End(xlUp).Offset(1)
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
Related
I have "Out of memory" issue with my Excel and VBA when I try to run macro below
Sub CopyPaste() ' macro to copy dynamic range
Dim lRow As Long
Dim sht As Worksheet
Set sht = Sheets("SQL")
sht.Activate
lRow = sht.Cells(sht.Rows.Count, 2).End(xlUp).Row
sht.Range("A1:Q" & lRow).Copy
Workbooks.Add
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:Q").EntireColumn.AutoFit
End Sub
My idea is to copy dynamic range from SQL tab in excel and paste to new workbook as values, columns to be autofit and all cells centered.
I have powerful machine at home, tried to reboot it and restart excel just in case.
Please, try the next adapted code. It does not activate, select anything. They are useless, only consuming Excel resources. Since you try copying only values, you also do not need using Clipboard:
Sub CopyPaste() ' macro to copy dynamic range
Dim lRow As Long, sht As Worksheet
Set sht = Sheets("SQL")
lRow = sht.cells(sht.rows.count, 2).End(xlUp).row 'last row on B:B column
Workbooks.Add
With sht.Range("A1:Q" & lRow)
ActiveSheet.Range("A1").Resize(.rows.count, .Columns.count).Value = .Value
End With
Columns("A:Q").EntireColumn.AutoFit
End Sub
If B:B is not the column you like to be the reference for the last used range cell, please change it using the necessary column number (instead of 2 in sht.cells(sht.rows.count, 2))
If you like using Clipboard, the next code will be suitable:
Sub CopyPaste() ' macro to copy dynamic range
Sheets("SQL").Copy 'it creates a new workbook with THAT single sheet
'in case of existing columns after Q:Q, use the next code to clear. If not, delete the next code lines:
Dim lastCol As Long
lastCol = ActiveSheet.cells(1, .ActiveSheet.Columns.count).End(xlToLeft).column
If lastCol > 17 Then
Range(cells(1, 18), cells(1, lastCol)).EntireColumn.Clear
End If
End Sub
If no any column after Q:Q, the code may have only a code line...
New VBA user here, the below code matches the 1st column in a worksheet with the 1st column in another worksheet using vlookup then copies the first cell from 1st to 2nd as the screenshots.
Code
Sub solution()
Dim oldRow As Integer
Dim newRow As Integer
Dim lrow_output As Integer 'variable indicating last fulfilled row
Dim WB_Input As Workbook
Dim WB_Output As Workbook
Dim WS_Input As Worksheet
Dim WS_Output As Worksheet
Dim funcStr As String
Set WB_Input = Workbooks("input")
Set WB_Output = Workbooks("output1")
Set WS_Input = WB_Input.Worksheets("input")
Set WS_Output = WB_Output.Worksheets("Sheet1")
With WS_Output
lrow_output = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With WS_Input
funcStr = "=IFERROR(VLOOKUP(" & Cells(1, 1).Address(False, False) & "," & "'[" & WB_Input.Name & "]" & .Name & "'!" & Range(.Columns(1), .Columns(2)).Address & ",2,0),"""")"
End With
With WS_Output
.Cells(1, 2).Formula = funcStr
.Cells(1, 2).Copy
Range(.Cells(1, 2), .Cells(lrow_output, 2)).PasteSpecial xlPasteFormulas
WS_Output.Calculate
Range(.Cells(1, 2), .Cells(lrow_output, 2)).Copy
Range(.Cells(1, 2), .Cells(lrow_output, 2)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End Sub
Problem: I need the code to copy and paste the all data in the row, not just the first cell.
Problem2:If possible I need the code to scan multiple sheets, not just one so it would be 1 input main workbook sheet and 4 output sheets in the output workbook.
Problem3(Optional): if possible I need the successfully matched and copied rows in the input workbook to be colored to tell them from the unsuccessful matches.
Thank you in advance, I really appreciate all the possible aid.
Here is a quick macro that will take the active cell row copy it and then select specified sheet and paste it in active cell row:
Sub CopyPaste()
'
' CopyPaste Macro
'
'
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Sheet#").Select
ActiveCell.Rows("1:1").EntireRow.Select
ActiveSheet.Paste
End Sub
Dim lastrow&, lastCol&, myarray As Range
lastrow = Range("A1").End(xlDown).Row
lastCol = Range("XX1").End(xlToLeft).Column
Set myarray = Range("A1").Resize(lastrow, lastCol)
Range("A1", myarray).Select
So i added the above code to recognise the last column and last row and copy the array
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Application.WindowState = xlNormal
Windows("Ex-Pakistan Calculator Final.xlsm").Activate
Sheets("MRG").Select
'has to find the last row by itself
Range("A" & Rows.Count).End(xlUp).Offset(2, 0).Select
ActiveSheet.Paste
Getting an error on the last line "activesheet.paste" saying copy and pasting area isn't the same size, try selecting one cell. enter image description here
Thing is, "Range("A" & Rows.Count).End(xlUp).Offset(2, 0).Select" does only select one cell, so I don't see the issue.
Following is an ideal way to copy and paste using range selection. You can change this code as per your requirement.
Sub CopyPaste()
Dim selectRange As range
Dim lastrow As Integer
Application.CutCopyMode = False
Sheets("Sheet1").Activate
lastrow = range("A1").End(xlDown).Row
Set selectRange = range("A1:A" & lastrow)
selectRange.Copy
Sheets("Sheet2").range("B1:B" & lastrow).PasteSpecial xlPasteAll
End Sub
Congrats on starting to use VBA. There's several things in your code that could use improvement. You want to avoid using select (a common beginner task). You also don't even need to move around your sheet, or even use copy/paste.
However, see below where I've broken up your code with some statements to stop and check where you're at. I think this will accomplish what you want, but also help you gain a better grasp of what you're doing (it's always a battle getting started!)
Keep battling.
Sub adfa()
Const turnOnStops As Boolean = True 'change to true or false to review code
Dim WS_Pull As Worksheet:
Set WS_Pull = ActiveSheet 'better to define this with actual sheet name
Dim lastrow As Long:
lastrow = WS_Pull.Cells(Rows.Count, 1).End(xlUp).Row 'this assumes column a has the bottom row and no rows hidden
If turnOnStops Then
Debug.Print "Lastrow is " & lastrow
Stop
End If
Dim lastcol As Long:
lastcol = WS_Pull.Cells(1, Columns.Count).End(xlToLeft).Column 'same assumptions but with columns on row 1 instead of columna a
If turnOnStops Then
Debug.Print "lastcol is " & lastcol
Stop
End If
Dim myarray As Range:
Set myarray = WS_Pull.Range("A1").Resize(lastrow, lastcol) ' I'm not sure what you're trying to do here.
If turnOnStops Then
Dim theAnswer As Long
theAnswer = MsgBox("The address of myArray is " & myarray.Address & ". Stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
Dim WS_paste As Worksheet: Set WS_paste = Sheets("MRG") 'it would be better to use the SHEET (shown in the VBA project)
WS_Pull.Range("A1", myarray).Copy '<--- what are trying to copy.
If turnOnStops Then
theAnswer = MsgBox("The area copied was " & WS_Pull.Range("A1", myarray).Address & ". Stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
If turnOnStops Then
theAnswer = MsgBox("The area you are going to paste to is " & _
WS_paste.Cells(1, Rows.Count).End(xlUp).Offset(2, 0).Address & " stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
End Sub
I have some code that almost works exactly as I'd like, below. At the moment, I have two sheets, one for Y-department, and one for X-department. I'd like a button to pass a range of cells (A:L) from the Y-department sheet to the X-department sheet. I don't want to paste the entire row because there are formulae from M-W in the X-department sheet, which get overwritten when I do that.
At the moment, this almost works. But it only lets me pass one row at a time. Is it possible to edit this code so that I can select more than one row at a time and it will cut and paste (only cells A:L of) all of those rows onto the X-department sheet?
Thanks in advance!
Sub Pass_to_Xdepartment()
If MsgBox("Do you want to pass the selected tours to Xdepartment?", vbYesNo, "Pass to XDepartment") = vbNo Then Exit Sub
For Each WSheet In ActiveWorkbook.Worksheets
If WSheet.AutoFilterMode Then
If WSheet.FilterMode Then
WSheet.ShowAllData
End If
End If
For Each DTable In WSheet.ListObjects
If DTable.ShowAutoFilter Then
DTable.Range.AutoFilter
DTable.Range.AutoFilter
End If
Next DTable
Next WSheet
'Declare variables
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim lastRow As Long
'Set variables
Set sht1 = Sheets("YDepartment")
Set sht2 = Sheets("XDepartment")
'Select Entire Row
Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row).Select
'Move row to destination sheet & Delete source row
lastRow = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
With Selection
.Copy Destination:=sht2.Range("A" & lastRow + 1)
.EntireRow.Delete
End With
End Sub
Also, out of interest, do you know if there's a way to set up this button so that it sends an email at the same time as passing over the data to notify X-department when rows have been passed over to their sheet? This is a secondary concern though.
Some suggestions, some "must haves":
Avoid using Select in Excel VBA
Obviously Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row) is only one row because ActiveCell is a single cell not a range of cells. If you want to get columns A to L of the selected range use …
Selection.EntireRow.Resize(ColumnSize:=12) '= first 12 columns of selection
All your Range and Cells should be specified with a worksheet like sht1.Range.
Use meaningful variable names eg replace sht1 with wsSource and sht2 with wsDestination which makes your code much easier to understand.
Don't test your message box like If MsgBox(…) = vbNo Then instead test for If Not MsgBox(…) = vbYes. Otherwise pressing the X in the right top corner of the window has the same effect as pressing the Yes button.
Make sure you really mean ActiveWorkbook (= the one that has the focus / is on top) and not ThisWorkbook (= the one this code is running in).
I recommend to activate Option Explicit: In the VBA editor go to Tools › Options › Require Variable Declaration and declare all your variables properly.
So you end up with something like:
Option Explicit
Public Sub Pass_to_Xdepartment()
If Not MsgBox("Do you want to pass the selected tours to Xdepartment?", vbYesNo, "Pass to XDepartment") = vbYes Then
Exit Sub
End If
Dim ws As Worksheet, DTable As ListObject
For Each ws In ThisWorkbook.Worksheets
If ws.AutoFilterMode Then
If ws.FilterMode Then
ws.ShowAllData
End If
End If
For Each DTable In ws.ListObjects
If DTable.ShowAutoFilter Then
DTable.Range.AutoFilter
DTable.Range.AutoFilter
End If
Next DTable
Next ws
Dim wsSrc As Worksheet
Set wsSrc = ThisWorkbook.Worksheets("YDepartment")
Dim wsDest As Worksheet
Set wsDest = ThisWorkbook.Worksheets("XDepartment")
Dim LastRow As Long
LastRow = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row
'Move row to destination sheet & Delete source row
With Selection.EntireRow.Resize(ColumnSize:=12) '= A:L of the selected rows
.Copy Destination:=wsDest.Cells(LastRow + 1, "A")
.EntireRow.Delete
End With
End Sub
Edit according to comments (write date):
Since you delete the copied rows anyway you can first write the date to column M
Intersect(Selection.EntireRow, Selection.Parent.Columns("M")).Value = Date
And then copy A:M instead of A:L
With Intersect(Selection.EntireRow, Selection.Parent.Range("A:M")) '= A:M of the selected rows
.Copy Destination:=wsDest.Cells(LastRow + 1, "A")
.EntireRow.Delete
End With
I have a macro that copies row by row of a selected range and pastes it on the next one. Maybe it'll help out.
Also, if you know the number of rows you're working with, you can always do
Range(Ax:Lx).Select
If not, this might do the trick:
Dim i As Integer
i = 2 //1 if first row isn't headers.
Do While sht1.Range("A" & i).Value <> Empty
sht1.Range("A" & i & "L" & i).Select
Selection.Copy
sht2.Range("A" & lastrow +1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
i = i + 1
Loop
Let me know if it helps or it needs adjustment.
I have no experience with VBA and it's proving to be more difficult than what I imagined...in part because I don't know the syntax, but I have the following:
Sub testMe()
LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Worksheets("Sheet2").Range("A1").Copy Destination:=Range("A" & LastRow)
End Sub
This kinda works, but it's jamming everything into one cell in the first column. How do I merge the cells of the last row before pasting into it? The macro is supposed to find the last row of the last page, merge the cells of that row, and paste text that was copied from another cell. Thank you in advance.
This should do what you're after. You should just change the column number to reflect the column which you wish to merge cells until.
Option Explicit
Sub copy_and_paste_merge()
Dim last_row As Long
last_row = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(1, 1).Copy
Cells(last_row, 1).PasteSpecial Paste:=xlPasteValues
Range(Cells(last_row, 1), Cells(last_row, 5)).MergeCells = True 'change the column
End Sub
I ended up doing it like this...
Sub testMe()
LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Range("A" & LastRow & ":L" & LastRow).Merge
Range("A" & LastRow) = Worksheets("Sheet2").Range("A1")
End Sub