I am new to this forum but have been reading a large number of posts recently as I am currently self teaching VBA for use at work!
I currently am having an issue with a bit of code that I have created. The aim of the code is to autofilter multiple sheets depending on a cell value that is double clicked on, it then copies these filtered results to another "Master Report" sheet. The issue is that it runs perfectly fine once, after which if I try to run it again or any of my other macro's within the workbook an error pops up asking me to close things to free up memory!
I have tried running the macro once, saving and closing the workbook (to clear anything that might be cached), re-opening and running and yet the same error persists. I also tried changing my .select prompts with .activate as suggested by:
How to avoid running out of memory when running VBA
but that seemed to break my code... then again I may have just implemented it wrong as I am a bit of a VBA noob Can anyone help me optimize my code to prevent this?
my code is as below:
Private Sub Merge()
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
Selection.Merge
End Sub
-------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("Master Report").Cells.Delete 'clear old master report
Column = Target.Column
Row = Target.Row
'this automatically filters information for a single part and creates a new master report with summary information
PartNumber = Cells(Row, 2).Value 'capture target part number for filtering
PartDesc = Cells(Row, 7).Value 'capture target part description
PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms
With Worksheets("NCR's") 'filter NCR sheet
.Select
On Error Resume Next
ActiveSheet.ShowAllData 'remove any previous filters
On Error GoTo 0
.Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
End With
Sheets("NCR's").Select
Sheets("NCR's").Range("A3:K3").Select
Sheets("NCR's").Range(Selection, Selection.End(xlDown)).Select 'select NCR filtered summary info
Selection.Copy
Sheets("Master Report").Select
Sheets("Master Report").Range("A1").Formula = PartNumber
Sheets("Master Report").Range("D1").Formula = PartDesc 'Print part no. & description at top of master report
Sheets("Master Report").Range("A4").Select
ActiveSheet.Paste 'paste filtered NCR info into master report
Sheets("Master Report").Range("A3:K3").Select
Call Merge
ActiveCell.FormulaR1C1 = "NCR's"
With Worksheets("CR's") 'filter CR sheet
.Select
On Error Resume Next
ActiveSheet.ShowAllData 'remove any previous filters
On Error GoTo 0
.Range("A1").AutoFilter Field:=3, Criteria1:=PartNumberWildCard
End With
Sheets("CR's").Select
Sheets("CR's").Range("A7:F7").Select
Sheets("CR's").Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Master Report").Select
Sheets("Master Report").Range("P4").Select
ActiveSheet.Paste
Sheets("Master Report").Range("RP3:U3").Select
Call Merge
ActiveCell.FormulaR1C1 = "CR's"
With Worksheets("PO's") 'filter PO sheet
.Select
On Error Resume Next
ActiveSheet.ShowAllData 'remove any previous filters
On Error GoTo 0
.Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
End With
Sheets("PO's").Select
Sheets("PO's").Range("A3:H3").Select
Sheets("PO's").Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Master Report").Select
lastRow = Sheets("Master Report").Range("A" & Rows.Count).End(xlUp).Row
lastRow = lastRow + 3
Sheets("Master Report").Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Master Report").Range("A" & lastRow - 1 & ":H" & lastRow - 1).Select
Call Merge
ActiveCell.FormulaR1C1 = "PO's"
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Another piece of info that may help is that I tried removing the last of the three filter/copy/paste routines, this allowed me to run the code about 3 times before running into the same memory error. Also the Debugger always gets stuck on the command to clear the master report at the beginning of the macro
Sheets("Master Report").Cells.Delete 'clear old master report
There are a couple of tips to speed up your macro and make it use less memory (less selecting, copying pasting). For a start it would be better to loop through your sheets rather than one long script for every one.
Dim arrShts As Variant, arrSht As Variant
arrShts = Array("NCR's", "CR's", "PO's")
For Each arrSht In arrShts
Worksheets(arrSht).Activate
'rest of your code'
Next arrSht
In the array add any other sheets you need to run the script on
Declaring variables is recommended also:
Dim masterws As Worksheet
Set masterws = Sheets("Master Report")
masterws.Activate
masterws.Range("A1").Formula = PartNumber
I haven't been able to do this 100% accurately, but you could limit your code down to something like the following
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Application.ScreenUpdating = False
Application.EnableEvents = False
Column = Target.Column
Row = Target.Row
PartNumber = Cells(Row, 2).Value 'capture target part number for filtering
PartDesc = Cells(Row, 7).Value 'capture target part description
PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms
Dim arrShts As Variant, arrSht As Variant, lastrw As Integer
Dim masterws As Worksheet
Set masterws = Sheets("Master Report")
masterws.Cells.Clear 'clear old master report
arrShts = Array("NCR's", "CR's", "PO's")
For Each arrSht In arrShts
Worksheets(arrSht).Activate
lastrw = Sheets(arrSht).Range("K" & Rows.Count).End(xlUp).Row
With Worksheets(arrSht) 'filter NCR sheet
On Error Resume Next
ActiveSheet.ShowAllData 'remove any previous filters
On Error GoTo 0
.Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
End With
Range(Cells(3, 1), Cells(lastrw, 11)).Copy
lastRow = Sheets("Master Report").Range("A" & Rows.Count).End(xlUp).Row
masterws.Activate
masterws.Range("A1").Formula = PartNumber
masterws.Range("D1").Formula = PartDesc 'Print part no. & description at top of master report
masterws.Range("A" & lastRow).PasteSpecial xlPasteValues
masterws.Range("A" & lastRow - 1 & ":H" & lastRow - 1).Select
Call Merge
ActiveCell.FormulaR1C1 = arrSht
Application.CutCopyMode = False
Next arrSht
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
This is in no way complete, and will edit as I find bits, but a good place to start to reduce the strain of your macro.
try this refactoring of your code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
Dim iRow As Long
Dim PartNumber As String, PartDesc As String, PartNumberWildCard As String
Dim masterSht As Worksheet
Set masterSht = Worksheets("Master Report")
cancel = True
iRow = Target.Row
PartNumber = Cells(iRow, 2).Value 'capture target part number for filtering
PartDesc = Cells(iRow, 7).Value 'capture target part description
PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms
'clear old master report and write headers
With masterSht
.Cells.ClearContents
.Cells.UnMerge
.Range("A1").Value = PartNumber
.Range("D1").Value = PartDesc 'Print part no. & description at top of master report
FilterAndPaste "NCR's", "K1", 2, PartNumberWildCard, .Range("A4")
FilterAndPaste "CR's", "F1", 3, PartNumberWildCard, .Range("P4")
FilterAndPaste "PO's", "H1", 2, PartNumberWildCard, .Cells(rows.count, "A").End(xlUp).Offset(3)
End With
End Sub
Sub FilterAndPaste(shtName As String, lastHeaderAddress As String, fieldToFilter As Long, criteria As String, targetCell As Range)
With Worksheets(shtName)
.AutoFilterMode = False 'remove any previous filters
With .Range(lastHeaderAddress, .Cells(.rows.count, 1).End(xlUp))
.AutoFilter Field:=fieldToFilter, Criteria1:=criteria
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then
.Resize(.rows.count - 1).Offset(1).SpecialCells(XlCellType.xlCellTypeVisible).Copy Destination:=targetCell
With targetCell.Offset(-1).Resize(, .Columns.count)
Merge .Cells
.Value = shtName
End With
End If
End With
End With
End Sub
Private Sub Merge(rng As Range)
With rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Merge
End With
End Sub
should it work for you, as it did in my tests, then I can add you some info, if you care about
Related
I have this VBA code which is used to consolidate the different tabs to one single sheet.Now the issue here is its taking too long to copy each line item to one single sheet. Need an update so that i could set print area as range and copy the sheets back to one.
ActiveWorkbook.Worksheets("Master Sheet").Activate
Rows("2:" & Rows.Count).Cells.ClearContents
totalsheets = Worksheets.Count
For i = 1 To totalsheets
If Worksheets(i).Name <> "Master Sheet" Then
lastrow = Worksheets(i).Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To lastrow
Worksheets(i).Activate
Worksheets(i).AutoFilterMode = False
Worksheets(i).Rows(j).Select
Selection.Copy
Worksheets("Master Sheet").Activate
lastrow = Worksheets("Master Sheet").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Master Sheet").Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Next
End If
Next
MsgBox "Completed"
ActiveWorkbook.Save
End Sub
First of all, avoid selecting worksheets and cells: Worksheets(i).Activate, Rows(j).Select. This is the most time-consuming. Usually it can be replaced with direct links.
Next, don't repeat Worksheets(i).AutoFilterMode = False inside the loop for j, it will be enough to do it once before For j = 2 To lastrow.
Third, don't copy row-by-row. Instead, copy the entire sheet:
Dim lastCell As Range
Set lastCell = Sheets("Sheet1").Range("A1").SpecialCells(xlLastCell)
Sheets("Sheet1").Range(Range("A1"), lastCell).Copy
Try this code, please. It it is fast, working mostly in memory, using arrays:
Sub testConsolidate()
Dim sh As Worksheet, shM As Worksheet, lastRowM As Long, arrUR As Variant
Set shM = ActiveWorkbook.Worksheets("Master Sheet")
shM.Rows("2:" & Rows.Count).Cells.Clear
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Master Sheet" Then
sh.AutoFilterMode = False
lastRowM = shM.Cells(Cells.Rows.Count, 1).End(xlUp).row
arrUR = sh.UsedRange.Offset(1).value 'copy from row 2 down
shM.Cells(lastRowM + 1, 1).Resize(UBound(arrUR, 1), _
UBound(arrUR, 2)).value = arrUR
End If
Next
MsgBox "Completed"
ActiveWorkbook.Save
End Sub
I'm using a table to pull information from separate work books.currently the table has a set end cell, but I'm pulling into too much information. I want to set the end cell to the last row of the data in column D. I need help modifying the code to set the end cell to a dynamic range.
I've already tried to use lastRow = .Cells(.Rows.Count, col).End(xlUp).Row but I keep getting
compile error
at the preceding .Offset that is invalid or unqualified reference
Sub GetData()
Dim strWhereToCopy As String, strStartCellColName As String
Dim strListSheet As String
Dim strCopySheet As String
strListSheet = "List"
On Error GoTo ErrH
Sheets(strListSheet).Select
Range("B2").Select
'this is the main loop, we will open the files one by one and copy their data into the masterdata sheet
Set currentWB = ActiveWorkbook
Do While ActiveCell.Value <> ""
strFileName = ActiveCell.Offset(0, 1) & ActiveCell.Value
strCopyRange = ActiveCell.Offset(0, 2) & ":" & lastRow =
.Cells(.Rows.Count, col).End(xlUp).Row
strWhereToCopy = ActiveCell.Offset(0, 4).Value
strCopySheet = ActiveCell.Offset(0, 6).Value
strStartCellColName = Mid(ActiveCell.Offset(0, 5), 2, 1)
Application.Workbooks.Open strFileName, UpdateLinks:=False,
ReadOnly:=True
Set dataWB = ActiveWorkbook
Sheets(strCopySheet).Select
Range(strCopyRange).Select
Selection.Copy
currentWB.Activate
Sheets(strWhereToCopy).Select
lastRow = LastRowInOneColumn(strStartCellColName)
Cells(lastRow + 1, 1).Select
Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
Application.CutCopyMode = False
dataWB.Close False
Sheets(strListSheet).Select
ActiveCell.Offset(1, 0).Select
Loop
Exit Sub
ErrH:
MsgBox "It seems some file was missing. The data copy operation is not
complete."
Exit Sub
End Sub
I have a Spreadsheet "upload" I run a macro to compile the data on the sheet. I have a column "D" which attributes the data to client. I want to look for a specific client and automatically move those rows to another worksheet. I have tried this code, but I am making an error "Upload.Range("D1", Upload.Range("D" & Upload.Rows.Count)"
I anticipate future clients information to need be separated from the initial spreadsheet as well.
Any Help would be much appreciated
Sub TransferData()
Dim ar As Variant
Dim i As Integer
Dim lr As Long
ar = Array("3032")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 0 To UBound(ar)
Upload.Range("D1", Upload.Range("D" & Upload.Rows.Count).End(xlUp)).AutoFilter 1, ar(i), 4, , 0
lr = Upload.Range("D" & Rows.Count).End(xlUp).Row
If lr > 1 Then
Upload.Range("A2", Upload.Range("G" & Upload.Rows.Count).End(xlUp)).Copy Sheets(ar(i)).Range("A" & Rows.Count).End(3)(2)
Upload.Range("A2", Upload.Range("G" & Upload.Rows.Count).End(xlUp)).Delete
Sheets(ar(i)).Columns.AutoFit
End If
Next i
[G1].AutoFilter
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Data transfer completed!", vbExclamation, "Status"
End Sub
There is a substantial difference between the worksheet Name property and the worksheet Codename property.
While it is possible to change the worksheet's Codename, it isn't a common practice and if you are unsure then it is most likely that you are referring to the worksheet Name property.
Your narrative says nothing about wanting the 'bottom 10 results' but your code uses 4 for the xlBottom10Items operator (see xlAutoFilterOperator enumeration ).
I have no idea what the 3 in Sheets(ar(i)).Range("A" & Rows.Count).End(3)(2) is intended to represent. I would suppose that you meant xlUp which has a numerical value of -4162. (see xlDirection enumeration).
Sub TransferData()
Dim ar As Variant
Dim i As Long, lr As Long
ar = Array("3032")
' ... app environment settings removed for brevity
'reference the filter worksheet properly
With Worksheets("Upload")
lr = .Range("D" & Rows.Count).End(xlUp).Row
If .AutoFilterMode Then .AutoFilterMode = False
For i = LBound(ar) To UBound(ar)
'there was no mention of 'bottom 10 items in your narrative but your code shows that option
With .Range("D1:D" & lr)
'.AutoFilter field:=1, Criteria1:=ar(i), _
Operator:=xlBottom10Items, VisibleDropDown:=False
.AutoFilter field:=1, Criteria1:=(ar(i)), VisibleDropDown:=False
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.Offset(0, -3).Resize(, 7).Copy _
Destination:=Worksheets(ar(i)).Range("A" & Rows.Count).End(xlUp)(2)
Worksheets(ar(i)).Columns.AutoFit
.Delete shift:=xlUp
End If
End With
End With
Next i
If .AutoFilterMode Then .AutoFilterMode = False
End With
' ... app environment settings removed for brevity
MsgBox "Data transfer completed!", vbExclamation, "Status"
End Sub
That should get you started. It seems you still have a few decisions o make based on my notes.
Application.CutCopyMode = False
See Should I turn .CutCopyMode back on before exiting my sub procedure?.
I have some problems with a piece of code. I get an error when it has to select a range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim valrand As Long
If Intersect(Target, ActiveCell) = "Insert line" Then
valrand = ActiveCell.Row
If Worksheets("IR").Cells(valrand, 18).Value <> 5 Then
Sheets("Format").Select
MsgBox ("Format")
Range("A13:N13").Select 'here's the error
Selection.Copy
Sheets("IR").Select
Range("A" & valrand + 2 + Worksheets("IR").Cells(12, 18) & ":N" & valrand + 2 + Worksheets("IR").Cells(12, 18)).Select
Selection.Insert Shift:=xlDown
Range("A38:N38").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A5").Select
contor = Worksheets("IR").Cells(12, 18).Value + 1
Worksheets("IR").Cells(12, 18).Value = contor
End If
End If
End Sub
Where I put the commet "here's the error" it gives me "Select method of Range class failed"
What am I doing wrong? Usually this piece of code worked before I added in the SelectionChange code block.
Thanks!
You should look at avoiding Select when using Sheet code (best to avoid it altogether, more later on this) and use something like this instead
Application.Goto Sheets("Format").Range("A13:N13")
(I had tried fully qualifying the reference but this only worked if I used
Sheets("Format").Select
Sheets("Format").Range("A13:N13").Select
which is clearly overkill)
While that solves you immediate issue you should look at consolidating your code, for example
Disabling Events so that other sheet events dont fire while your Select is running
Removing any Select statements
This is an example of what may work better (now with no sheet activation)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lngRand As Long
Dim rng1 As Range
Set ws1 = Sheets("Format")
Set ws2 = Sheets("IR")
If Intersect(Target, ActiveCell) = "Insert line" Then
lngRand = ActiveCell.Row
If ws2.Cells(lngRand, 18).Value <> 5 Then
Application.EnableEvents = False
Set rng1 = Range("A" & lngRand + 2 + ws2.Cells(12, 18))
'extend rng1 from column A to colum N
Set rng1 = rng1.Resize(rng1.Rows.Count, 14)
ws2.Range(rng1.Address).Insert xlDown
'copy Format to IR
ws1.Range("A13:N13").Copy ws2.Range(rng1.Address)
'Update Format
ws2.Range("A38:N38").Delete Shift:=xlUp
ws2.Cells(12, 18).Value = ws2.Cells(12, 18).Value + 1
Application.EnableEvents = True
End If
End If
End Sub
I'm trying to copy a range of rows where the rows chosen are based on the value in one cell.I want to do this for all rows containing the same value in a cell, then move on to the next value an append to the bottom of the first list.
Below is my attempt at explaining what I wish to achieve - hopefully the above will help explain more my dilemma. I have looked around for this but not quite found what I want. I thought it would be simple and probably is.
I receive a data dump with thousands of rows of data and 18 columns. Based on the value of column P "Contract" I want to copy entire rows into a new single worksheet workingdata. Not all the data will go into the workingdata worksheet.
The contract numbers are c1234, c1235, c2345 etc.
What i am after achieving is copying and sorting, so copy all the rows of data where contract number is c1234, in workingdata, then directly below it copy all rows where contract is c1235 and so on.
I thought I could select the range P:P and sort but to no avail.
Sheets("Data Dump").Select
Columns("P:P").Select
If Selection.Value = "C1234" Then
Selection.EntireRow.copy
I know I should post what i have tried, but it would be a pathetic, for some reason I just can't seem to get my head round this one.
Here's my latest effort - I know there are errors
Dim oWorksheet As Excel.Worksheet
Dim oRangeSource As Excel.Range
Dim oRangeDest As Excel.Range
Set oWorksheet = Worksheets("DataDump")
Set oRangeSource = oWorksheet.Range("p:p")
Set oRangeDest = Worksheets("workingdata")
If oRangeSource="CA0004000" Then Select.EntireRow
Selection.EntireRow.copy
Sheets("workingdata").Select.Paste
End If
latest effort but does not sort data or get rid of unwanted, I have to do a manual filter and sort which sorts of defeats the object of the macro
Sub copy()
'
' copy Macro
'
Dim rngContracts As Range: Set rngContracts = Sheets("DataDump").Range("P:P")
Dim wsData As Worksheet
Dim wsFound As Boolean: wsFound = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Working Data" Then
Set wsData = ws
wsFound = True
Exit For
End If
Next ws
If wsFound = False Then
Application.CutCopyMode = False
ActiveSheet.Range("A1").EntireRow.copy
Set wsData = Sheets.Add(After:=Sheets(Sheets.Count))
wsData.Name = "Working Data"
wsData.Range("A1").EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Dim iCell As Range
For Each iCell In rngContracts
If iCell.EntireRow.Hidden = False Then
Application.CutCopyMode = False
iCell.EntireRow.copy
wsData.Range("P" & Rows.Count).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Next iCell
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Latest attaempt - copies the data I need but does not sort:
Sub copytest()
'
' copytest Macro
'
Set MR = Sheets("data Dump").Range("P:P")
For Each cell In MR
If cell.Value = "CA000154" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000220" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000393" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000429" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
Record a macro to set filters on your data select one filter only.
Then, edit the code and loop through each filter copying the visible range on to your sheet. This must also sort your data as the filters are already sorted.
Also, take a look at creating filter arrays in the Excel VBA help with regards to using them to sort.