Excel copy range and paste in a specific range available and print - vba

I would like to copy a range in one sheet and paste it as a value in another sheet, but just in a specific range in the next available cell in column B. Starting from B4 to B23 only.
I changed some code I found online but it's not working for me in finding the next available row. After I run the macro the first time, when I run it again and again it does nothing, and it's not working in pasting only the values either.
I tried saving the file before running the Macro again, but still it's not working.
At the end, when the range in the Print sheet is full, I would like a message box asking me to select one of the printers (not the default) on one of my servers (specifying the server path in the code like \a_server_name) and print this Print Sheet only, or clear the records in the range in the Print Sheet, or save only the Sheet Print in a new file (SaveAs) to a location I can choose on one of my servers (specifying the server path in the code \a_server_name) or simply do nothing and end the sub.
Thank you.
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets(“Data”)
Set pasteSheet = Worksheets("Print”)
copySheet.Range("J11:Q11").Copy
pasteSheet.Range("B4:I23").End(xlUp).Offset(1,0)
.PasteSpecial.xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True

This will set the values equal to each other without copying/pasting.
Option Explicit
Sub Testing()
Dim wsC As Worksheet: Set wsC = ThisWorkbook.Sheets("Data")
Dim wsP As Worksheet: Set wsP = ThisWorkbook.Sheets("Print")
Dim LRow As Long
LRow = wsP.Range("B" & wsP.Rows.Count).End(xlUp).Offset(1).Row
wsP.Range("B" & LRow).Resize(wsC.Range("J11:Q11").Rows.Count, wsC.Range("J11:Q11").Columns.Count).Value = wsC.Range("J11:Q11").Value
End Sub
Modifying your code - and reducing to minimal example
Sub test()
Dim copySheet As Worksheet: Set copySheet = Worksheets("Data")
Dim pasteSheet As Worksheet: Set pasteSheet = Worksheets("Print")
copySheet.Range("J11:Q11").Copy
pasteSheet.Range("B" & pasteSheet.Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End Sub

From what i can gather, you want to copy 8 cells and paste all 8 cells to 20 rows, starting at B4. You are not clear on how you want to rerun the macro, it will just write over the data you just pasted.
The first code will copy the 8 cells into the 20 rows
With ThisWorkbook
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Range("B4:I23").PasteSpecial Paste:=xlPasteValues
End With
This second code uses a for loop to accoplish the same task, but it also will write over the previously pasted data.
Dim i As Long
With ThisWorkbook
For i = 4 To 23
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(i, 2).PasteSpecial Paste:=xlPasteValues
Next i
End With
If you want to be able to reuse the macro, you will have to modify the range to be copied that allows you to select the range you want to copy. Maybe a variable that allows a user input with a InputBox.
Edit:
Dim lRow As Long
lRow = Sheets("Print").Cells(Rows.Count, 2).End(xlUp).Row
With ThisWorkbook
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(lRow, 2).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
Edit #3
With ThisWorkbook
Dim lRow As Long
lRow = .Sheets("Print").Range("B" & Rows.Count).End(xlUp).Row
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(lRow, 2).Offset(1).PasteSpecial Paste:=xlPasteValues
End With

Related

Copy specific range to first available row in another worksheet and transpose

The code below runs smoothly, and copies the data from Workbook1 to Workbook2 on the first available row, starting from column B. I need to know when the data was submitted, and therefore want the time and date to be inserted into the first available cell in column A each time data is submtited. Thanks for your help!
Option Explicit
Sub MoveData()
'Define variables
Dim Workbook1 As Workbook
Dim Workbook2 As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long, DestLastRow As Long
'Set wb
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
'Copy (In this case I want to copy range D4:D7 only, and this will be the same every time)
ThisWorkbook.Sheets("Sheet1").Range("D4:D7").Copy
'Open Workbook 2 and paste data (transposed) on first available row starting in column B
Set Workbook2 = Workbooks.Open("H:\Macro FSC\Forsøk10\Workbook2.xlsm")
With Workbook2.Sheets("Sheet1")
' find last row with data in destination workbook "Workbook2.xlsm"
DestLastRow = .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Row
'paste special only values, and transpose
.Range("B" & DestLastRow).PasteSpecial xlValues, Transpose:=True
End With
'Save and close
Workbook2.Save
Workbook2.Close
End Sub
Try this, it's a one line solution
Option Explicit
Sub MoveData()
'Define variables
Dim Workbook1 As Workbook
Dim Workbook2 As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long, DestLastRow As Long
'Set wb
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
'Copy (In this case I want to copy range D4:D7 only, and this will be the same every time)
ThisWorkbook.Sheets("Sheet1").Range("D4:D7").Copy
'Open Workbook 2 and paste data (transposed) on first available row starting in column B
Set Workbook2 = Workbooks.Open("H:\Macro FSC\Forsøk10\Workbook2.xlsm")
With Workbook2.Sheets("Sheet1")
' find last row with data in destination workbook "wbDatabase.xlsm"
DestLastRow = .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Row
'paste special only values, and transpose
.Range("B" & DestLastRow).PasteSpecial xlValues, Transpose:=True
'Added line here:
.range("A1").Value = now
End With
'Save and close
Workbook2.Save
Workbook2.Close
End Sub

Search for next blank cell in another sheets and paste

I am new using macro of Excel, and this is the first time I ask a question here.
I did some research here about this problem, but still can't solve it.
I have several sheets named :page 1, page 2, etc, and I want to copy the data in specific range and paste them to the sheets named "ULD".
When I run the macro in page 1, everything works perfect. But when I run it in page 2 or other sheet, the new data will paste and replace the data pasted from page 1.
The following is my vba code:
Sub test()
Dim ws As Worksheet
Set ws = Sheets("ULD")
'Only Copy Visible Cells'
Range("L3:L100").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("ULD").Activate
For Each cell In ws.Range("I4:I10").Cells
If IsEmpty(cell) = True Then cell.Select.Paste: Exit For
Next cell
End Sub
Besides, I want the data being paste only value, how should I write the code?
There is some confusion, this is how I interpret what you are trying to do.
Sub test2()
Dim ws As Worksheet, LstRw As Long
Set ws = Sheets("ULD")
With ws
LstRw = .Cells(.Rows.Count, "I").End(xlUp).Row
End With
'Only Copy Visible Cells'
Range("L3:L100").SpecialCells(xlCellTypeVisible).Copy
ws.Range("I" & LstRw + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = 0
End Sub

Allow append of data to a summary sheet in another workbook

I have this code which appends data from three worksheets to a summary sheet, however on execution it is taking 12 of the 13 rows from sheet 1 and 2 and thirteen from sheet 3 to the summary I also would like this to work by sending to a summary sheet in a different workbook
Sub SummurizeSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" Then
ws.Range("D2:D6, D8:D15").Copy
Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp).Offset(0, 0).PasteSpecial (xlPasteValues)
End If
Next ws
End Sub
Change Offset(0,0) to Offset(1,0). What's happening is not that it's copying 12 rows, but rather that the subsequent blocks are being pasted starting at the end of the previous block. That is, the first block is pasted into D1:D13, and the second block is pasted into D13:D26. By using Offset(1,0), the second block will be pasted starting with the first empty cell (that is, D14).
You can place the results in a new workbook simply by creating it in the code and referring to it in the paste, for example:
Option Explicit
Sub SummurizeSheets()
Dim ws As Worksheet
Dim currentWB As Workbook: Set currentWB = ActiveWorkbook
Dim newWB As Workbook: Set newWB = Application.Workbooks.Add
newWB.Worksheets(1).Name = "Summary"
For Each ws In currentWB.Worksheets
ws.Range("D2:D6, D8:D15").Copy
With newWB.Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp)
If IsEmpty(.Value) Then
.PasteSpecial (xlPasteValues)
Else
.Offset(1, 0).PasteSpecial (xlPasteValues)
End If
End With
Next ws
End Sub
EDIT updated to paste into the first empty cell in column, even if that is row 1.

Read/Write Large Amounts of Data

I'm working on copying large amounts of data from one spreadsheet to the other 160 spreadsheets in the workbook. Currently, Excel (2013) runs into an error as it does not have enough resources to complete the operation.
My goal is to copy data in the range V13:XI1150 in sheet 4 to sheets 5-160. I tried splitting up the range that the code is stored in (see variables rng1 and rng2), as well as grouping 10 worksheets together (although I realize this has little effect).
Is there a way to streamline the code I'm working on here so I can successfully copy this data over?
Thanks in advance.
Sub copypaste()
'''''''''Globals'''''''''''''
Dim j As Long 'Loop control variable
Dim sheetstart As Integer 'starting sheet variable
Dim sheetend As Integer 'ending sheet variable
Dim rng1 As Range 'range to copy
Dim rng2 As Range 'Second range
Application.Calculation = xlCalculationManual 'Sets manual calculation
Application.ScreenUpdating = False 'Turns off screen updating
sheetstart = 5 'first sheet to copy over in loop
sheetend = 15 'last sheeet to copy over in loop
With Sheets(4) 'Selects the 4th sheet
Set rng1 = Range("V13:LO1150") 'Stores first half of data in rng
Set rng2 = Range("LP13:XI1150") 'Stores second half of data in rng
End With
For j = 1 To 16 'loops through all groups of 10 sheets
copypaste10 rng1, sheetstart, sheetend 'calls copypaste10 function
copypaste10 rng2, sheetstart, sheetend 'calls copypaste10 function
sheetstart = sheetstart + 10 'increments to next 10 sheets
sheetend = sheetend + 10 'increments to next 10 sheets
Next
Application.Calculation = xlCalculationAutomatic 'Sets auto calculation
Application.ScreenUpdating = True 'Turns on screen updating
End Sub
Public Function copypaste10(rng As Range, sstart As Integer, sstop As Integer)
'''''''''Locals'''''''''''''
Dim i As Long 'Loop control
Dim WS As Worksheet 'worksheet being worked on
Dim ArrayOne() As String 'Array of sheets we are working on
ReDim ArrayOne(sstart To sstop) 'Array of sheets
''''''''''Calcuations'''''''''''''
For i = sstart To sstop
ArrayOne(i) = Sheets(i).Name
Next
For Each WS In Sheets(ArrayOne)
WS.Rows(2).Resize(rng.Count).Copy
rng.Copy Destination:=WS.Range("v13")
Next WS
End Function
I ran a quick test with the following code, and it ran just fine:
Sub test()
Application.ScreenUpdating = False
Dim rng As Range
Set rng = Worksheets("Sheet1").Range("V13:XI1150")
rng.Copy
For i = 2 To 161
Sheets(i).Select
Range("V13").Select
ActiveSheet.Paste
Next
Application.ScreenUpdating = True
End Sub
There was only static data in my test cells, not formulas. That may make the difference, because when you turn Automatic Calculation back on, that will be a gigantic hit to your system resources, especially if it is a complex calculation in your cells.
It could be extra Copy that you're doing in your loop i.e.
WS.Rows(2).Resize(rng.Count).Copy
That copy will store to memory even though you don't seem to be pasting it anywhere (to be honest though, I'm not sure whether or not that i.e. the clipboard will clear that after exiting the function or as needed)
Nonetheless, this is an alternate solution if you don't have formulas in your range origin.
Since your destination is always the same, and your origin ranges are the same dimension (just different starting points), you can avoid the copy / paste all together :
For Each WS In Sheets(ArrayOne)
WS.Range("V13:LO1150") = rng.Value
Next WS
Again, note that it will only copy the values over to your destination sheets
*--EDIT--*
If you do need the formulas you can change .Value to .Formula, but note that this will "paste" formulas that refer to the origin sheet, not the relative references of your destination sheet. I would also turn auto calculations off before running the macro (Application.Calculation = xlCalculationManual, and either calculate or turn on calculations at the end (Application.Calculation =xlCalculationAutomatic) or maybe after every few "pastes" by using Application.Calculate.

Copy and Paste Largest value in a column from one workbook to another

I am attempting to first, find the the largest value in a column (C), then copy and paste that value into the next empty cell in 'Row 3' in a different (master) workbook. The macro I am running is found in the master workbook. I found this code that i believe will get the pasted cell into the correct spot, but I could use assistance in the code for how to find the largest cell in column C in the data workbook, and then copying and pasting that value.
Private Sub CommandButton1_Click()
Dim wsMaster As Worksheet, wbDATA As Workbook
Dim NextColumn As Long, LastRow As Long
Set wsMaster = ThisWorkbook.Sheets("Contract Metrics")
NextColumn = wsMaster.Range("C", 3).End(xlUp).Column + 1
Set wbDATA = Workbooks.Open("C:\Documents and Settings\Michael Palkovitz\My Documents\Test\Contracts Metrics.xlsx")
wbDATA.Close False
End Sub
Try this. First sort the column you need the value from, then get the last row and place the value into your first empty column in row 3 of your master sheet.
' Create an excel application and open the workbook containing the data
Dim app As Object
Dim wb As Object
Dim ws As Object
Set app = CreateObject("Excel.Application")
Set wb = app.Workbooks.Open("C:\Workbook1")
Set ws = wb.Sheets(1)
' Get last row with a value to use for the sort range
Dim last As Long
Dim value As Long
With ws
last = ws.Cells(ws.Rows.Count, 3).End(xlUp).row
.Range("C1:C" & last).Sort Key1:=.Range("C2"), order1:=xlAscending, Orientation:=xlTopToBottom
value = .Cells(last, 3)
End With
' Get the last filled cell and move over one to get the empty column
Dim col As Long
col = ActiveSheet.Cells(3, 1).End(xlToRight).Offset(0, 1).Column
ActiveSheet.Cells(3, col).value = value
wb.Close False
Set ws = Nothing
Set wb = Nothing
Set app = Nothing