First VBA code... looking for feedback to make it faster - vba

I wrote a small VBA macro to compare two worksheets and put unique values onto a new 3rd worksheet.
The code works, but every time I use if excel goes "not responding" and after 30-45sec comes back and everything worked as it should.
Can I make this faster and get rid of the "not responding" issue? is it just my computer not being fast enough?
I start with about 2500-2700 rows in each sheet I'm comparing.
Sub FilterNew()
Dim LastRow, x As Long
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values
Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet
Sheets(1).Select
LastRow = Range("B1").End(xlDown).Row
Application.ScreenUpdating = False
For Each Cell In Range("B2:B" & LastRow)
x = 2 'This is for looking through rows of sheet2
Dim unique As Boolean: unique = True
Do
If Cell.Value = Sheets(2).Cells(x, "B").Value Then 'Test if cell matches any cell on Sheet2
unique = False 'If the cells match, then its not unique
Exit Do 'And no need to continue testing
End If
x = x + 1
Loop Until IsEmpty(Sheets(2).Cells(x, "B"))
If unique = True Then
Cell.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next
Application.ScreenUpdating = True
End Sub

This belongs in Code Review, but here is a link
http://www.excelitems.com/2010/12/optimize-vba-code-for-faster-macros.html
With your code your main issues are:
Selecting/Activating Sheets
Copy & pasting.
Fix those things and youll be set straight my friend :)

instead of a do...loop to find out duplicate, I would use range.find method:
set r = SHeets(2).range("b:b").find cell.value
if r is nothing then unique = true else unique = false
(quickly written and untested)

What about this (it's should help):
Sub FilterNew()
Dim Cel, Rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values
Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet
Set Rng = Sheet(1).Range("B2:B" & Sheet(1).Range("B1").End(xlDown).Row)
For Each Cel In Rng
If Cel.Value <> Sheet(2).Cells(Cel.Row, 2).Value Then Cel.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) ' The only issue I have with this is that this doesn't actually tell you if the value is unique, it just tells you ins not on the same rows of the first and second sheet - Is this alright with you?
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Related

Filtering depending upon the column values

I have a sheet FC, with this sheet, I have column R, S and T filled.
I would prefer to have a code, which checks if R contains "invalid" and if S and t are filled, then it should filter complete row.
I know we can use isblank function to check whether the cell is blank or not,
but I am struck how I can use a filter function with these condition .Any help will be helpful for me. I am struck how I can proceed with a vba code. Apologize me for not having a code.
You will have to somehow specify last row:
Dim lastRow, i As Long
For i = 1 To lastRow 'specify lastRow variable
If InStr(1, LCase(Range("R" & i).Value), "invalid") > 0 And Range("S" & i).Value = "" And Range("T" & i).Value = "" Then
'do work
End If
Next i
In our If condition we check three things that you asked.
Try this
Sub Demo()
Dim lastRow As Long
Dim cel As Range
With Worksheets("Sheet3") 'change Sheet3 to your data sheet
lastRow = .Cells(.Rows.Count, "R").End(xlUp).Row 'get last row in Column R
For Each cel In .Range("R5:R" & lastRow) 'loop through each cell in range R5 to lase cell in Column R
If cel.Value = "invalid" And Not IsEmpty(cel.Offset(0, 1)) And Not IsEmpty(cel.Offset(0, 2)) Then
cel.EntireRow.Hidden = True 'hide row if condition is satisfied
End If
Next cel
End With
End Sub
EDIT :
To unhide rows.
Sub UnhideRows()
Worksheets("Sheet3").Rows.Hidden = False
End Sub
Assuming Row1 is the header row and your data starts from Row2, in a helper column, place the formula given below.
This formula will return either True or False, then you may filter the helper column with either True or False as per your requirement.
=AND(R2="Invalid",S2<>"",T2<>"")
In case your header row is different, tweak the formula accordingly.
sub myfiltering()
'maybe first row always 4
firstrow=4
'last, maybe R column alaways have any entered info, so let us see what is the last
lastrow=cells(65000,18).end(xlup).row
'go ahead
for myrow=firstrow to lastrow
if cells(myrow,18)="Invalid" and cells(myrow,19)="" and cells(myrow,20)="" then
Rows(myrow).EntireRow.Hidden = True
else
Rows(myrow).EntireRow.Hidden = false
end if
next myrow
msgbox "Filter completed"
end sub
hope this will help you :)
Why you need the vba code for this problem?
Its more simple if you add a new column with if & and formula, and autofiltering within the added col.
The formula may be similar like this in the U2 cell.
=if(and(R2="invalid";S2="";T2="");"x";"")
Also set autofilter to x. :)

MS Excel worksheet change event - keeping record of old cell value against new value

I'm new to this forum but have been building up my coding experience in the last couple of months due to the VBA requirements of my current role. Today's problem has seen me trawling through many sites (and my Excel VBA for Dummies book), but I haven't quite nailed it.
I am trying to make an audit tracker file in Excel for our company Risk Register. The idea is that once the risk register is established, any changes will create an audit trail (on a separate tab) which shows both the old and the new record.
I have written the code using the Change Event handler. I want my macro to fire every time there is a change and do the following:
1. Make a reference of the old cell value (what the user has just overwritten)
2. Jump to the 'Audit trail' tab and paste two copies of the full risk record - each risk record is a row of data that occupies 17 columns
3. In the first copy of these 17 columns, work out which column was edited and replace this cell with the old cell value (captured in step 1)
4. Insert a time stamp
5. Have conditional formatting highlight the record that has changed [this function is not required in the code as I've set it up within the spreadsheet itself]
6. Jump back to cell where the user just made their edit (on the 'Risk Register' tab)
I have managed steps 1, 2 and 4-7 but I am having problems getting the code to input the "old cell value" into the right spot in the 'Audit Tracker' tab. I can get it there if I manually define the cell range for it to paste into, but I can't seem to make it dynamic so that it will automatically recognize what field the user is changing and ensure the same field is amended in the audit trail.
Would really appreciate any insights as to why the "PasteRange.Value = Worksheets("Risk Register").Range("oldValuePaste")" line isn't working
My code is as follows:
Dim oldValue As Variant
Dim LastRow As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, Range("b13:r13")) Is Nothing Then
oldValue = Target.Value
End If
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, Range("b13:r14")) Is Nothing Then
If Target.Value <> oldValue Then
'MsgBox "You just changed " & Target.Address
Cells(65, 5).Value = oldValue 'this cell is a named range called: OldValuePaste
Cells(66, 5).Value = Target.row 'this cell is a named range called: OldValueRowNumber
Cells(67, 5).Value = Target.Column 'this cell is a named range called: OldValueColumnNumber
Range(Cells(Target.row, 2), Cells(Target.row, 18)).Copy
'Cells(70, 2).PasteSpecial xlPasteValues
Call Paste_on_AuditSheet
Sheets("Risk Register").Activate
Target.Select
Application.CutCopyMode = False
End If
End If
Application.ScreenUpdating = True
End Sub
_____________________________________________________________________________________________________
Sub Paste_on_AuditSheet()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim ColNum As Long
Dim PasteRange As Range
ColNum = OldValueColumnNumber
Sheets("Audit trail").Select
'MsgBox "Activated " & ActiveSheet.Name
'Find the last used row in a Column: column B in this example
With ActiveSheet
LastRow = .Cells(.Rows.Count, "B").End(xlUp).row
End With
Set PasteRange = Cells(LastRow, ColNum)
'The following two lines bring in the new data and paste into old record and new record sections:
Cells(LastRow + 1, 2).PasteSpecial xlPasteValues
Cells(LastRow + 1, 20).PasteSpecial xlPasteValues
'Then this line goes back over the piece just pasted in and changes one cell in "old record" section to what it was prior to the edit:
'PasteRange.Value = Worksheets("Risk Register").Range("oldValuePaste")
'Above line of code is not working, but can get it to do the right thing using this code (although it's not dynamic):
Range("E3").Value = Worksheets("Risk Register").Range("oldValuePaste")
'Add a time stamp:
Cells(LastRow + 1, 1) = Now
Application.ScreenUpdating = True
End Sub
One last point - despite my repeated use of Application.ScreenUpdating commands, I still get some screen flashing - any ideas why?
Thanks in advance for the help!
In reviewing your code, I saw a few things that I didn't think would work as you supposed they would, and also recognized that your code could be made much simpler and just be called from the Worksheet_Change event.
So the refactored code below and let me know if you have issues:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("b13:r14")) Is Nothing Then
'get oldValue
Dim sNewVal As String, sOldVal As String
sNewValue = Target.Value 'store current or "new" value since this is what is stored after the cell change takes place
With Application
.EnableEvents = False 'turns off event firing so the code will not go into endless loop
.Undo 'undo the change (to store old value in next line)
End With
sOldValue = Target.Value 'store old value
Target.Value = sNewValue 'reset new value
Dim lCol As Long
lCol = Target.Column 'which column of data was changed
'assumes columns A-Q are 17 columns
Me.Range(Me.Cells(Target.Row, 1), Me.Cells(Target.Row, 17)).Copy
With Sheets("Audit Trail")
Dim lRow As Long
lRow = .Range("B" & .Rows.Count).End(xlUp).Offset(1).Row
.Range("B" & lRow).PasteSpecial xlPasteValues
.Range("B" & lRow + 1).PasteSpecial xlPasteValues
.Range("A" & lRow).Value = Now
.Cells(lRow, lCol + 1).Value = sOldValue 'store old value in first pasted line ... add 1 since starting from column B
End With
End If
Application.EnableEvents = True
End Sub

If cell value matches a UserForm ComboBox column, then copy to sheet

What I am trying to do is :
loop through Column Q on Sheet "Global" starting at row 3
For every cell match value to UserForm ComboBox2 Column2, and the copy the entire row to the relevant sheet from userform2 coloum1.
loop though until last row. There could be several unique values in Column Q but will all be in the Userform2's Combobox2 columns.
I have no code as an example as I have no idea where to even begin!
This is my comboxbox, as is displays, on the backing of it each item have the below code, so a name, a code "2780" and a reference "BRREPAIRS".
.AddItem "Repairs"
ComboBox2.List(13, 1) = "2780"
ComboBox2.List(13, 2) = "BRRPEAIRS"
I need it to loop through everycell on the global sheet in column G, then match the cell value to the combobox list item from column 2. Once it has found a match it uses the code from column 1 ie "2780" to copy the entire row to the sheet matching the code in column 1.
Hopefully i have explained it a little better.
Private Sub CommandButton1_Click()
Dim findmatch As Object
Dim lastcell As Integer
Set findmatch = ThisWorkbook.Sheets("Global").Range("G:G").Find(What:=UserForm2.ComboBox2.column(1), LookIn:=xlValues)
If Not findmatch Is Nothing Then
lastcell = ThisWorkbook.Sheets(UserForm2.ComboBox2.Value).Cells(100000, 7).End(xlUp).row 'here find a way to locate last cell in sheet that has your name.. it keeps returning me 1 but other than that it works fine
ThisWorkbook.Sheets(UserForm2.ComboBox2.Value).Range(Cells(lastcell, 1), Cells(lastcell, 40)) = Range(Cells(findmatch.row, 1), Cells(findmatch.row, 40)).Value
Else
MsgBox "not found"
End If
End Sub
I have managed to get it to work with the following code below. It looks for the correct cell in the combobox. Then copies it to the correct sheet in the correct position.
The only problem is that it runs very slowley!! Can anyone suggest some way of speeding it up?
And the last question is, having error handling for if a sheet doesn't exists, it tell you to create the sheet, or even create the sheet for you??
I really appreciate all the help guys, have been bashing my head on the wall for days!!!
Dim i, lastD, lastG As Long
Dim j As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With
' find last row
lastG = sheets("Global").Cells(Rows.Count, "Q").End(xlUp).row
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
' loop over values in "details"
For j = 0 To Me.ComboBox2.ListCount - 1
currVal = Me.ComboBox2.List(j, 2)
If lookupVal = currVal Then
sheets("Global").Cells(i, "Q").EntireRow.Copy
sheets(Me.ComboBox2.List(j, 1)).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End If
Next j
Next i
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
End With

Partial row copying from one sheet to another and mixed type data cell comparing

I have a working macro, that basically cuts row from base sheet, if values in rows fist cell (column A) matches a value in target sheets cell = B1, and to paste it in target sheets first empty row (checks cells in column A). But as the functionality of my Excel needs to be slightly changed, I need to make some adjustments, but all my attempts have failed so far.
Here is the working code:
Sub RowCopy()
Application.ScreenUpdating = False
Set shtarget = Sheets("TargetSheet")
Set shBase = Sheets("BaseSheet")
For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
If shBase.Cells(i, 1).Value = shtarget.Cells(1, 2).Value Then
shBase.Rows(i).EntireRow.Cut
shtarget.Rows(shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Insert Shift:=xlDown
shBase.Rows(i).EntireRow.Delete
End If
Next i
Application.CutCopyMode = False
Set shtarget = Nothing
Set shBase = Nothing
Application.ScreenUpdating = True
End Sub
And here are issues, which I'm dealing with:
Issue nr.1:
The code does not work if cell B1 contains mixed text and number and (dash/comma/space), for example: "white - 32". I've tried to use Variant, but it did not work correctly each time and made data sorting quite slower especially with large data amount.
Here I've tried to compare two cells with StrComp, the code itself didn't show any errors, but also did not do the thing that it should do - which is - copying data to target sheet:
Sub RowCopy()
Application.ScreenUpdating = False
Set shtarget = Sheets("TargetSheet")
Set shBase = Sheets("BaseSheet")
For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
If StrComp(shBase.Cells(i, 1).Value, shtarget.Cells(1, 2).Value) = 0 Then
shBase.Rows(i).EntireRow.Cut
shtarget.Rows(shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Insert Shift:=xlDown
shBase.Rows(i).EntireRow.Delete
End If
Next i
Application.CutCopyMode = False
Set shtarget = Nothing
Set shBase = Nothing
Application.ScreenUpdating = True
End Sub
What am I missing?
Is there more efficient way to compare mixedtype data in cells?
Issue nr.2:
With the existing code, copying entire row interferes with data in target sheets right part of the page, as it is shifting rows down.
But, it is necessary to cut/copy certain part of row (for example: from A2:J2) from base sheet and paste only data in target sheets region from A to J, while not messing up other part of the target sheet.
It should act more like stepping 1 row down, not inserting and shifting rows, which is happening with the existing code.
I've tried substituting "EntireRow" with Range(A2:J2), but it only left me with necessary data missing and wrong data copying to my target sheet.
How to define specific Range of a row in code below to paste only data in target sheet, while not inserting new rows (and not messing up other data which is out of the target sheets A:J range)?
Sub RowCopy()
Application.ScreenUpdating = False
Set shtarget = Sheets("TargetSheet")
Set shBase = Sheets("BaseSheet")
For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
If shBase.Cells(i, 1).Value = shtarget.Cells(1, 2).Value Then
shBase.Rows(i).EntireRow.Cut
shtarget.Rows(shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Insert Shift:=xlDown
shBase.Rows(i).EntireRow.Delete
End If
Next i
Application.CutCopyMode = False
Set shtarget = Nothing
Set shBase = Nothing
Application.ScreenUpdating = True
End Sub
I don't see any issues with searching for (eg) "white - 32"...
Sub RowCopy()
Dim shtarget As Worksheet, shBase As Worksheet
Dim vGet, cDest As Range, i As Long
Application.ScreenUpdating = False
Set shtarget = Sheets("TargetSheet")
Set shBase = Sheets("BaseSheet")
'get initial paste position
Set cDest = shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Offset(1, 0)
'value being searched for
vGet = shtarget.Cells(1, 2).Value
For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
If shBase.Cells(i, 1).Value = vGet Then
shBase.Cells(i, 1).Resize(1, 10).Copy cDest 'copy 10 columns
shBase.Rows(i).EntireRow.Delete
Set cDest = cDest.Offset(1, 0)
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

get two cells to print from same page

I was wondering if its possible to have a macro that populates a page and prints it then goes to the next one from the column and so on.
The number would go on Sheet2, C2 and name on C4. this is a template so it should delete empty and then refresh the next number and name from the list in sheet1.
The only thing is could it be set so I can select the starting cell or does it have to print all in the row at once? Say I only wanted to print 20 today then another 50 tomorrow can that be done....
Its a lot of manual typing at the moment so any help would be great.
I have an example below (names changed) that the column could have up to 500 names that need to be printed to place in each folder. Below put the number in correctly I just cant work out how to also include the name from cell D2 in sheet1
Sub PrintLoop()
Dim c As Range, LR As Long
Application.ScreenUpdating = False
LR = Sheets("sheet1").Range("C" & Rows.Count).End(xlUp).Row
For Each c In Sheets("sheet1").Range("C2:C" & LR)
Sheets("sheet2").Range("C2").Value = c.Value
Sheets("sheet2").PrintPreview
Next c
Application.ScreenUpdating = True
End Sub
Select just the rows you want to print before running...
Sub PrintLoop()
Dim rw As Range
Application.ScreenUpdating = False
For Each rw In Selection.Rows
With Sheets("sheet2")
.Range("C2").Value = rw.EntireRow.Cells(3).Value
.Range("C4").Value = rw.EntireRow.Cells(4).Value
.PrintPreview
'.PrintOut From:=1, To:=1, Copies:=1
End With
Next rw
Application.ScreenUpdating = True
End Sub