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...
Related
I have two sheets. One has the complete data and the other is based on the filter applied on the first sheet.
Name of the data sheet : Data
Name of the filtered Sheet : Hoky
I am just taking a small portion of data for simplicity. MY objective is to copy the data from Data Sheet, based on the filter. I have a macro which somehow works but its hard-coded and is a recorded macro.
My problems are:
The number of rows is different everytime. (manual effort)
Columns are not in order.
Sub TESTTHIS()
'
' TESTTHIS Macro
'
'FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B$2:$F$12").AutoFilter Field:=5, Criteria1:="hockey"
'Data Selection and Copy
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hockey").Select
Range("E3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("D3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("C3").Select
ActiveSheet.Paste
End Sub
Best way of doing it
Below code is to copy the visible data in DBExtract sheet, and paste it into duplicateRecords sheet, with only filtered values. Range selected by me is the maximum range that can be occupied by my data. You can change it as per your need.
Sub selectVisibleRange()
Dim DbExtract, DuplicateRecords As Worksheet
Set DbExtract = ThisWorkbook.Sheets("Export Worksheet")
Set DuplicateRecords = ThisWorkbook.Sheets("DuplicateRecords")
DbExtract.Range("A1:BF9999").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Cells(1, 1).PasteSpecial
End Sub
I suggest you do it a different way.
In the following code I set as a Range the column with the sports name F and loop through each cell of it, check if it is "hockey" and if yes I insert the values in the other sheet one by one, by using Offset.
I do not think it is very complicated and even if you are just learning VBA, you should probably be able to understand every step. Please let me know if you need some clarification
Sub TestThat()
'Declare the variables
Dim DataSh As Worksheet
Dim HokySh As Worksheet
Dim SportsRange As Range
Dim rCell As Range
Dim i As Long
'Set the variables
Set DataSh = ThisWorkbook.Sheets("Data")
Set HokySh = ThisWorkbook.Sheets("Hoky")
Set SportsRange = DataSh.Range(DataSh.Cells(3, 6), DataSh.Cells(Rows.Count, 6).End(xlUp))
'I went from the cell row3/column6 (or F3) and go down until the last non empty cell
i = 2
For Each rCell In SportsRange 'loop through each cell in the range
If rCell = "hockey" Then 'check if the cell is equal to "hockey"
i = i + 1 'Row number (+1 everytime I found another "hockey")
HokySh.Cells(i, 2) = i - 2 'S No.
HokySh.Cells(i, 3) = rCell.Offset(0, -1) 'School
HokySh.Cells(i, 4) = rCell.Offset(0, -2) 'Background
HokySh.Cells(i, 5) = rCell.Offset(0, -3) 'Age
End If
Next rCell
End Sub
When i need to copy data from filtered table i use range.SpecialCells(xlCellTypeVisible).copy. Where the range is range of all data (without a filter).
Example:
Sub copy()
'source worksheet
dim ws as Worksheet
set ws = Application.Worksheets("Data")' set you source worksheet here
dim data_end_row_number as Integer
data_end_row_number = ws.Range("B3").End(XlDown).Row.Number
'enable filter
ws.Range("B2:F2").AutoFilter Field:=2, Criteria1:="hockey", VisibleDropDown:=True
ws.Range("B3:F" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
Application.Worksheets("Hoky").Range("B3").Paste
'You have to add headers to Hoky worksheet
end sub
it needs to be .Row.count not Row.Number?
That's what I used and it works fine
Sub TransfersToCleared()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Application.Worksheets("Export (2)") 'Data Source
LastRow = Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A2:AB" & LastRow).SpecialCells(xlCellTypeVisible).Copy
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 a workbook which has approximately 300 worksheets. I'm trying to loop through each sheet, copy a specific range, and paste it on summary sheet. I need each successive paste to be put one row below the last used row. I'm newer to loops, but I think the amount of information being copied is excessive(causing an error), and I have come to understand that the .value method is much less memory intensive.
How do I incorporate the .value method to accomplish this? Here is the code I tried to write (again, I'm new to coding,sorry).
Sub Consolidation()
Dim ws As Worksheet
Sheets("Summary").Select
For Each ws InThisWorkbook.Sheets
ActiveSheet.Range("A" & Rows.Count).End(xLUp).Offset(1).Value ="ws.Range("BB1").End(xLToRight).End(xLDown).Select"
Next ws
End Sub
Alternatively, is there a better way to do this? Meaning, is the .value method the way to tackle this issue?
This question is similar than:
Simple Copy/Paste Loop not working on each worksheet
This is the way you can use the .Value
Sub WsLoop()
Dim ws As Worksheet
Dim Summary As Worksheet
Set Summary = ThisWorkbook.Sheets("Summary")
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = "Summary" Then 'This will skip Summary.
Summary.Range("A1").Value = ws.Range("A1").Value
End If
Next ws
End Sub
Sub loop_through_all_worksheets_cpyPst()
Dim ws As Worksheet
Dim starting_ws As Worksheet
Set starting_ws = Sheets("startAtSheet")
'remember which worksheet is active in the beginning
For Each ws In ThisWorkbook.Worksheets
ws.Activate
If Not ws.Name = "SheettoPasteTo_skipCopy" Then 'This will skip Summary.
Range("A2:I2").Select
'my section range had only columns till i - edit the to last column
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("SheettoPasteTo_skipcopy").Select
'edit this sheet name to copy to
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.End(xlDown).Select
End If
ws.Cells(1, 1) = 1 'this sets cell A1 of each sheet to "1"
Next
starting_ws.Activate
'activate the worksheet that was originally active
End Sub
I am trying to copy rows of data (which may or may not be filtered) and INSERT it into rows above existing data (sort of a rolling schedule). Below is my code that works for unfiltered data. If I apply any filters to the data to be copied, my macro will only copy 1 cell. Can anyone provide an example of a macro that can copy both filtered and unfiltered data?
Sub DynamicRange()
'Best used when first column has value on last row and first row has a value in the last column
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Dim SelectedRange As Range
Set sht = ActiveWorkbook.ActiveSheet
Set StartCell = Range("C9")
If IsEmpty(StartCell.Value) = True Then
MsgBox "Enter Dates to export"
Exit Sub
End If
'Find Last Row and Column
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column
'Select Range and Copy
Set SelectedRange = sht.Range(StartCell, sht.Cells(LastRow, LastColumn))
SelectedRange.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'Select sheet "TRACKER" insert values above previous data
Sheets("TRACKER").Select
Range("B9").Select
Selection.Insert Shift:=xlDown
'clear selection
Application.CutCopyMode = False
End Sub
I've rewritten your sub procedure and tried to avoid the use of .Select and Selection. Relying on properties like the ActiveCell¹ and ActiveSheet¹ is haphazard at best.
Sub DynamicRange()
Dim sc As Range, sht As Worksheet
Set sht = ActiveWorkbook.Worksheets("Sheet1") '<~~ set this worksheet reference properly
'btw, if you really needed ActiveWorkbook here then you would need it with Worksheets("TRACKER") below.
With sht
Set sc = .Range("C9") 'don't really have a use for this
If IsEmpty(.Range("C9")) Then
MsgBox "Enter Dates to export"
Exit Sub
End If
With .Range(.Cells(9, 3), .Cells(9, Columns.Count).End(xlToLeft))
With Range(.Cells(1, 1), .Cells(Rows.Count, .Columns.Count).End(xlUp))
'got the range; determine non-destructively if anything is there
If CBool(Application.Subtotal(103, .Cells)) Then
'there are visible values in the cells
.Cells.Copy _
Destination:=Worksheets("TRACKER").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
End If
End With
End With
End With
End Sub
The worksheet's SUBTOTAL function does not count hidden values so it is a good non-destructive test for the existence of visible values. You do not need to copy the Range.SpecialCells with the xlCellTypeVisible property specifically. A regular Range.Copy method will only copy visible cells. By immediately specifying the destination, there is no need to transfer the ActiveSheet property to the TRACKER worksheet; only the top-left corner of the destination need be specified.
¹ See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
I am using some code (found via: http://www.extendoffice.com/documents/excel/1184-excel-merge-multiple-worksheets-into-one.html) to merge 5 sheets, each with 1000 rows.
Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub
This seems to work perfectly, other than I need to have the sheets combined using a 'paste as values' methodology (as my individual sheets have many formulas, and I just want to combine them as text versions).
Can this code be easily changed to 'paste as values'?
Thanks.
Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Copy
Sheets(1).Range("A65536").End(xlUp)(2).PasteSpecial xlPasteValues
Next
End Sub
Does this work? If so, we can get working on removing .select to make this a little bit more "tight". I already did it on the .Copy line (can you see what I did?)
Edit: This almost gets there - I think you'll hit an issue on the pasting part, but I can fix that. Just tell me, in your original code, what is the CurrentRegion that you're selecting? What's trying to be copy/pasted?
Edit 2: Okay, I think I've got it finally. The issue is your using Sheets(1), Sheets(2). I don't know how your document is, but the following works with these assumptions: You have the "unchanging" sheet active (this is the sheet with your magical formulas). Just have this active and run the macro below.
Sub Combine()
Dim J As Integer, noRows As Integer
Dim ws1 As Worksheet, ws2 As Worksheet, magicWS As Worksheet
' Note, you need to have the worksheet where you do all of your formulas open and be the active sheet.
Set magicWS = ActiveSheet
Set ws1 = Sheets.Add(after:=magicWS)
ws1.Name = "Combined"
On Error Resume Next
'Now, I assume that your main (unchanging) worksheet is the FAR LEFT most
'Then, the second worksheet is the new "Combined". If you look along the bottom, every worksheet RIGHT of "Combined" will need
'to be added to this WS.
'First, let's get the headers from the third sheet:
ws1.Cells.Rows(1).Value = Sheets(3).Cells.Rows(1).Value
'Now, let's add the data to "Combined"!
For J = 3 To Sheets.Count
noRows = Sheets(J).Range("A1").CurrentRegion.Rows.Count
Sheets(J).Range("A1").CurrentRegion.Offset(1, 0).Resize(noRows - 1).Copy
ws1.Range("A65536").End(xlUp)(2).PasteSpecial xlPasteValues
Next J
Application.CutCopyMode = False
End Sub