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.
Related
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
I have 300 excel sheets with 20 columns(Including a column "Status"). I want to clear values to blank corresponding to the column "Status" from all the excel sheets without opening each of them. Currently i use to do this manually, but it is time consuming. Please suggest the best solution for this. Can it be done using a macro?
One way to achieve this would be as follows, this assumes that the column you want to clear is Column A, and the clearing takes place from Row 2 to the last row:
Sub foo()
Dim ws As Worksheet
Dim LastRow As Long
Application.ScreenUpdating = False 'disable ScreenUpdating to optimize the processing speed
Application.Calculation = xlCalculationManual 'change to manual to optimize the running of the code
For Each ws In ThisWorkbook.Worksheets 'loop through worksheets
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data in each worksheet
ws.Range("A2:A" & LastRow).Clear
'clear the specified range, in this case from Row 2 to Last
Next ws
Application.Calculation = xlCalculationAutomatic 'enable automatic calculations once code has finishe
Application.ScreenUpdating = True 're-set the screen updating
End Sub
I am trying to consolidate multiple large excel files into one single file using the following code
Sub Macro1()
Application.DisplayAlerts = False
Dim Country As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
k = 2
For i = 1 To 50
Windows("Try2").Activate
Country = Worksheets("Names").Cells(i, 1).Value
Workbooks.Open Filename:= "C:path\" & Country & " "
ActiveWorkbook.Sheets("Main").Activate
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
Workbooks(Country).Sheets("Main").Range(Cells(1, 1), Cells(10000, 64)).Copy
Workbooks("Try2").Sheets("Output").Activate
Workbooks("Try2").Sheets("Output").Cells(k, 2).PasteSpecial xlPasteValues
Range(Cells(k, 1), Cells(k + 10000, 1)) = Country
finalrow2 = 10002 + k
k = finalrow2 + 1
Workbooks(Country).Sheets("Main").Activate
Workbooks(Country).Close SaveChanges:=False
Next i
End Sub
However after consolidating 2-3 files excel it is throwing buffer overflow error. We have around 50 files. I am trying to figure out if this is just a problem with excel unable to handle large files or there is something wrong with my code. Is there any way to guide excel to handle larger files sizes?
There's a couple of things here that could be throwing your macro off.
First, you're declaring i, j, and k as the 'integer' data type; problem with that is that the largest possible value an integer can hold is 32,767. If you go above that, you're going to get a buffer overflow.
Second, you're declaring variables that you don't use, and not declaring variables that you do use. As far as I can see, j isn't used anywhere in the code, but finalrow and finalrow2 are used but aren't declared anywhere.
I would suggest you replace your integer data types that could go very high with long data types (long integer). You might also want to use more descriptive names for your integers to make your code easier to read:
Dim iCycler as integer
Dim kStart as long
Dim FinalRow as Long
Dim FinalRow2 as Long
Run through that and see what you get.
EDITED TO ADD:
Here is a complete process that should suit you:
Sub Duplicator()
'Define the source file, sheet, and range
Dim wbkSource As Workbook
Dim shtSource As Worksheet
Dim rngSource As Range
'Define the target file, sheet and range
Dim wbkTarget As Workbook
Dim shtTarget As Worksheet
Dim rngTarget As Range
'Define the sheet with the list of countries
Dim shtControl As Worksheet
'Prepare control integers
Dim iLoop As Integer
Dim lLastRow As Long
'Define the target file as the active workbook
Set wbkTarget = ActiveWorkbook
Set shtTarget = wbkSource.Sheets("Output")
Set rngTarget = shtTarget.Range("A2")
Set shtControl = wbkTarget.Sheets("Names")
'Loop through the list
For iLoop = 1 To 50
'Open the source file and assign it to a variable.
Set wbkSource = Workbooks.Open("C:\path\" & shtControl.Cells(iLoop, 1).Value)
'Assign the source sheet
Set shtSource = wbkSource.Sheets("Main")
'Find the last row of data
lLastRow = shtSource.Range("A" & Rows.Count).End(xlUp).Row
'Use the last row to build a source range variable
Set rngSource = shtSource.Range("A1", "BL" & lLastRow)
'Check that there is space for the copy. If there is not, create a new sheet for the new data
If rngTarget.Row + lLastRow > shtTarget.Rows.Count Then
Set shtTarget = wbkTarget.Sheets.Add
shtTarget.Name = "Output 2"
Set rngTarget = shtTarget.Range("A2")
End If
'Use the size of rngSource to define the size of the target range
Set rngTarget = rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count)
'Duplicate the values over
rngTarget.Value = rngSource.Value
'Prepare the target range for the next loop
Set rngTarget = shtTarget.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
'Close the source file
wbkSource.Close False
Next iLoop
End Sub
By declaring and using variables throughout, the code should be easier both to write and to read. It should also run quicker, since it's using the range1.value = range2.value structure, which bypasses the rather slow clipboard. It also contains a check to make sure that you're not surpassing 1,048,576 rows of data, which would cause a crash.
quite along the lines of good coding practice Werff already explained to you, you could try this other (commented) code:
Sub Macro1()
Dim outputSht As Worksheet '<--| declare a variable to set your "output" sheet to
Dim countryData As Variant, countryNames As Variant '<--| declare arrays to store "country names" and "country data" in
Dim country As Variant '<-- "countries" looping variable
Application.Calculation = xlCalculationManual '<-- disable calculations
Application.ScreenUpdating = False '<-- disable screen updating
With Workbooks("Try").Worksheets("Names") '<--| reference "country names" worksheet
countryNames = Application.Transpose(.Range("A1", .Cells(.Rows.count, 1).End(xlUp)).Value) '<--| store country names in column "A" from row 1 down to last not empty row
End With
Set outputSht = Workbooks("Try").Worksheets("Output") '<--| set "output" worksheet
For Each country In countryNames '<-- loop through countries stored in 'countryNames'
With Workbooks.Open(FileName:="C:path\" & Country).Sheets("Main") '<--| open current country workbook and reference its "Main" sheet
countryData = .Range("BL1", .Cells(.Rows.count, 1).End(xlUp)).Value '<--| store current country data in 'countryData' array
.Parent.Close SaveChanges:=False '<--| close current country workbook
End With
With outputSht '<--| reference output sheet
With .Cells(.Rows.count, 1).End(xlUp).Offset(1).Resize(UBound(countryData, 1)) '<--|reference its column A range from first empty cell after last not empty cell down to as many rows as current country array has
.Value = country '<--| write current country name in referenced range
.Offset(, 1).Resize(, 64).Value = countryData '<--| write country data array content from column B rightwards
End With
End With
Next country
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
since it uses arrays to store data, it suffers from the arrays maximum size limitation to 65536 rows. If your "countries" workbooks "Main" sheets have more rows than such a limit then different pasting values techniques must be adopted (like between range values)
I have cobbled together a subroutine to get two ranges of data from blocks of cells in two separate worksheets. Then, using the .Copy method, it puts the first block into (1, 1) of a third worksheet and the second block into the next available row of that worksheet.
The code I have written pretty much does what I want it to do, except that for some reason it will not paste the second range (declared as DataRng2 below) unless the sub is run twice in a row. Here is what I have:
Sub Test()
Dim DataRng As Range
Dim DataRng2 As Range
Dim Test As Worksheet
Dim EmtyRow As Range
Application.ScreenUpdating = False
Set Test = Worksheets("Test")
'Set the "EmptyRow" reference to whatever the next empty row is in the destination worksheet - checks column A
Set EmptyRow = Worksheets("Test").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
'Select all utilized cells in 82-Medicine tab and copy them
Worksheets("82-Medicine").Select
Set DataRng = Worksheets("82-Medicine").Cells(2, 1).CurrentRegion
'Select the destination worksheet and paste copied cells to A1
Test.Select
DataRng.Copy Cells(1, 1)
'Select all utilized cells in Fee Basis tab and copy them
Worksheets("Fee Basis").Select
Set DataRng2 = Worksheets("Fee Basis").Cells(2, 1).CurrentRegion
'Select the destination worksheet and paste copied cells to the next empty row
Test.Select
DataRng2.Copy EmptyRow
Application.ScreenUpdating = True
End Sub
Why do I have to run it twice to get it to work? Is there a way to fix that?
I should note that I am using the .CurrentRegion property to get the data only because rows of data will frequently be added to and subtracted from the ranges of cells I need to grab, and .CurrentRegion is the simplest way I know to grab the first range of whatever cells are occupied. I am open to using a different property or method if necessary.
Option Explicit
Sub Test()
Dim src_1 As Worksheet
Dim src_2 As Worksheet
Dim dest As Worksheet
Dim src_1_rng As Range
Dim src_2_rng As Range
Dim lr As Integer
Dim lc As Integer
Set src_1 = ThisWorkbook.Sheets("82-Medicine")
Set src_2 = ThisWorkbook.Sheets("FeeBasis")
Set dest = ThisWorkbook.Sheets("Test")
'' Set up range for data from '82-Medicine'
lr = src_1.Cells(2, 1).End(xlDown).Row
lc = src_1.Cells(2, 1).End(xlToRight).Column
Set src_1_rng = src_1.Range(src_1.Cells(2, 1), src_1.Cells(lr, lc))
'' Set up range for data from 'FeeBasis'
lr = src_2.Cells(2, 1).End(xlDown).Row
lc = src_2.Cells(2, 1).End(xlToRight).Column
Set src_2_rng = src_2.Range(src_2.Cells(2, 1), src_2.Cells(lr, lc))
'' Copy the data to the destination sheet ('Test')
src_1_rng.Copy dest.Range("A" & dest.Rows.Count).End(xlUp).Offset(1)
src_2_rng.Copy dest.Range("A" & dest.Rows.Count).End(xlUp).Offset(1)
End Sub
Not sure why that wouldn't work but try this. I've never been a fan of CurrentRegion or selecting different sheets during code. Why bother when you can just use references? This should work perfectly.
edit
Changed the lr and lc variables to use xlDown from (2,1) and xlToRight from (2,1) to properly get a "CurrentRegion"-esque range.
I am trying to select each consecutive cell in Row K (starting from Range K1), and for each cell going down, copy the value and paste it into Cell M10. However, the way the macro is written currently, the macro is selecting the cell right below the last cell in Range K, and is thus copying a blank into M10. Instead, I want the loop to work down one cell at a time. I want to select one cell at a time and copy it, i.e. the Loop will select K1 and copy it to M10, then select K2 and copy it to M10, etc, and then have the loop stop after the last cell of Range K.
Can anyone please help me out on this?
Sub test()
lastcell = Range("K" & Cells.Rows.Count).End(xlUp)
Range("K2").Select
Do
ActiveCell.Offset(1, 0).Select
Selection.Copy
Range("M10").Select
Selection.PasteSpecial
Application.Run ("Second Macro")
Loop Until IsEmpty(ActiveCell.Value)
End Sub
You can loop through column K using the small script below:
Option Explicit
Sub LoopThroughColumnK()
Dim LastRowInColK As Long, Counter As Long
Dim SourceCell As Range, DestCell As Range
Dim MySheet As Worksheet
'set references up-front
Set MySheet = ThisWorkbook.Worksheets("Sheet1")
With MySheet
LastRowInColK = .Range("K" & .Rows.Count).End(xlUp).Row
Set DestCell = .Range("M10")
End With
'loop through column K, copying from cells(counter, 11) to M10
With MySheet
For Counter = 1 To LastRowInColK
Set SourceCell = .Range("K" & Counter)
SourceCell.Copy Destination:=DestCell
'call MyMacro below
'... doing cool MyMacro stuff
Next Counter
End With
End Sub
To summarize what's happening, we:
Assign a worksheet variable to make sure we're working on the right sheet
Assign easy-to-read and reference variables for the last row and cell M10
Loop through the range in question, copying and pasting from Kn to M10
This technique also avoids using .Select, a common source of run-time errors. Here's an AMAZING post outlining lots of ways to NOT use .Select and .Activate: How to avoid using Select in Excel VBA macros
Edit: The refactoring I described in my comment above could be implemented without too much struggle. Let's break the whole problem into two bite-size chunks:
Get all the occupied cells in column K and save them as a Range
Running your secondary macro, which was keyed off cell M10, for each Cell in the Range we saved in step #1 above. We'll call the secondary macro MyOtherMacro for now
Let's get after it. Sunday Funday y'all! The code below is heavily-commented to explain what's happening in each function and step:
Option Explicit
Sub DoWork()
Dim MySheet As Worksheet
Dim ColKRange As Range
'set the worksheet we want to work on, in this case "Sheet1"
Set MySheet = ThisWorkbook.Worksheets("Sheet1")
'get the range of occupied cells in col K
Set ColKRange = OccupiedRangeInColK(MySheet)
'kick off the other macro using the range we got in the step above
Call MyOtherMacro(ColKRange)
End Sub
DoWork (above) is a "controller"-type script. All it does is kick off the other two functions we have written below, OccupiedRangeInColK and then, one step later, MyOtherMacro.
'this function returns a range object representing all
'the occupied cells in column K, starting at row 1 and ending
'at the last occupied row (in column K)
Public Function OccupiedRangeInColK(TargetSheet As Worksheet) As Range
Dim LastRow As Long
'check for unassigned worksheet object, return nothing if that's the case
If TargetSheet Is Nothing Then
Set OccupiedRangeInColK = Nothing
End If
With TargetSheet
LastRow = .Range("K" & .Rows.Count).End(xlUp).Row
Set OccupiedRangeInColK = .Range(.Cells(1, 11), .Cells(LastRow, 11))
End With
End Function
Cool -- descriptive names are a great thing when it comes to scripting. OccupiedRangeInColK (above) takes a Worksheet, then returns the occupied Range from column K.
'this function is a shell to be populated by #polymorphicicebeam
Public Function MyOtherMacro(TargetRange As Range)
Dim Cell As Range
'check for an empty range, exit the function if empty
If TargetRange Is Nothing Then Exit Function
'loop through all the cells in the passed-in range
For Each Cell In TargetRange
'Do cool stuff in here. For demo purposes, we'll just
'print the address of the cell to the screen
MsgBox (Cell.Address)
Next Cell
End Function
Finally, MyOtherMacro (above) is where you get to add your own magic. I built a "shell" function for you, which simply prints the address of the cell in question with a MsgBox. You can add your own logic where indicated inside the For Each Cell In TargetRange loop. Woo!