**Thanks all for the pointers on how to as well as the Code Review section. Today I switched over to pulling and comparing the numbers by making an array for each group of numbers. It works in seconds now rather than minutes. **
I have working code, it does the job just fine. It's purpose is to check and report if there are any duplicate loan numbers by comparing the ReadyForExport (normally about 60 rows) sheet to the PastLoanLog sheet (presently about 1300 rows) one by one.
Question: Any ideas on how to code this better? It takes a few minutes to run, but if there is a way I can make it run faster, that's what I am searching for. Here is the code:
Sub DupTest2()
'This runs through the RFE list, checks the 2nd mortgage numbers
'and reviews against the PastLoanLog spreadsheet
MsgBox ("This may take a minute")
OpenSheets 'Opens worksheets needed to run the program
Dim TestDpaNum As String
Dim PastDpaNum As String
Dim lRow As Integer
Dim DupNum As Integer
Dim h As Integer
Dim i As Integer
Dim lrowHFE As Integer
Sheets("ReadyForExport").Select
Range("G2").Select
lrowHFE = Cells(Rows.Count, 1).End(xlUp).Row
Debug.Print "Ready For Export LR " & lrowHFE
'Locate Last Row In PastLoanLog Data
'**********************************
Sheets("PastLoanLog").Select
Range("G2").Select
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("ReadyForExport").Select
Range("G2").Select
For h = 2 To lrowHFE
'Finds the first loan number to check against the old data
TestDpaNum = ActiveCell.Value
Sheets("PastLoanLog").Select
Range("G2").Select
For i = 1 To lRow
'Selects current cell to compare with cell from RFE sheet
PastDpaNum = ActiveCell.Value
If PastDpaNum = TestDpaNum Then
DupNum = DupNum + 1
Debug.Print "Duplicate Found" & TestDpaNum
Sheets("ErrorSheet").Range(DupNum, 6).Value = TestDpaNum
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Next
Sheets("ReadyForExport").Select
ActiveCell.Offset(1, 0).Select
Debug.Print "CurrentRow=" & h
Next
'Sends the info to the Dashboard
Debug.Print "Dups = " & DupNum
Sheets("Dashboard").Select
Range("P16").Select
ActiveCell.Value = DupNum
ActiveCell.Offset(1, 0).Value = Now()
CloseSheets
End Sub
Related
My sheet contains of cars that are placed at a certain location and need to be checked. This list is made twice a day and sometimes contains of 10 rows, sometimes 14, sometimes 12 etc. Now I would like to cut half of the rows and place it next to the other rows (in this case paste it in cell E). I would like to automate this process so in the VBA should be:
Count number of rows (X)
Cut the rows from X/2 to X
Paste the data in cell E1
I found this function which returns the middle cell. However, I would like to put this together in a sub.
Function Middle(r As Range) As Variant
Dim i As Long, j As Long
If r.Columns.Count > 1 Then
Middle = [#N/A]
Exit Function
End If
i = r.Row
j = r.Rows.Count
Middle = Cells(i + (j - 1) / 2, r.Column).Address
End Function
Sub cutting()
Range("Middle:C" & Range("A" & Rows.Count).End(xlUp).Row).Select
Selection.Cut
Range("E2").Select
ActiveSheet.Paste
Range("A1:C1").Select
Selection.Copy
Range("E1").Select
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Range("E8").Select
End Sub
Before
After
You don't need to select the data to work with it.
Try:
Sub Test()
Dim lLastRow As Long
Dim lCutRow As Long
With ThisWorkbook.Worksheets("Sheet1") 'Change Sheet1 to the name of your sheet.
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Find last row in column A.
If lLastRow > 1 Then
lCutRow = (lLastRow / 2) + 1
.Range(.Cells(lCutRow, 1), .Cells(lLastRow, 3)).Cut Destination:=.Cells(1, 5) 'Paste to row 1, column 5 (E1).
End If
End With
End Sub
I'm writing a simple Excel VBA program to search through the entire client database, looking for the specific record. While doing this, I've encountered a problem - after encountering first match, it does the instructions well and stops.
The database consists of 500+ rows and looks like this:
Column A Column B Column C Column D
Name xxxx yyy zzzz
Here's some simplified code
Sub Analizuj_1_Click()
Dim SearchName As String
Dim CColumn As Integer
Dim Match As Boolean
Dim CRow As Integer
Dim CRowPaste As Integer
On Error GoTo Err_Execute
LDate = Range("NazwaKlienta").Value
Sheets("2019").Select
'Starting in Column A, Row 2'
LColumn = 1
LRow = 2
LRowPaste = 2
LFound = False
While LFound = False
'Found a blank cell -> terminate'
If Len(Cells(CRow, 1)) = 0 Then
MsgBox "Klient nie ma zaległości"
Exit Sub
'Found Match
Szukaj: ElseIf Cells(CRow, 1) = SearchName Then
Cells(CRow, 1).EntireRow.Select
Selection.Copy
Sheets("test").Select
Cells(CRowPaste, 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
LFound = True
CRowPaste = CRowPaste + 1
Sheets("2019").Select
'Continuation"
ElseIf Cells(CRow, 1).Value > 0 Then
CRow = CRow + 1
GoTo Szukaj
End If
Wend
Exit Sub
Err_Execute:
MsgBox "Blad."
End Sub
Even If I try to continue searching through Start statement, it stops at the first found match. I tried to experiment with other methods and still the same problem.
Inb4 I know, selecting is not the most efficient method for anything
I have a Workbook in which there is a sheet named "tracker" that shows certain actionables that need to be closed by team member by target date. I can do it on excel using filters. But I tried ti build a VBA code to automate the process which is
Search for Status of action in column 28. If it is "Open" then Check if "target date" in column 43 is exited as of today. I put today date in column 46. If Target date is exceeded then I want that row to be copy pasted in another worksheet "Open Items". The code should move to next item in 2 situations, either the status is "closed" of Target date is yet to arrive.
Following is code I wrote. The code is executed properly but I get only the last row as output in Open items sheet. The code do not seem to check for status or dates properly
Sub OpenItems()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Sheets("Open Items").Select
Cells.Select
'Range("E16").Activate
Selection.Delete Shift:=xlUp
Sheets("Observation Tracker").Select
Range("A2").Select
Sheets("Observation Tracker").Activate
Lastrow = Cells(Rows.Count, "AQ").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets("Observation Tracker").Cells(Rows.Count,"AU").End(xlUp).Row + 1
For i = 2 To Lastrow
If Cells(i, 28).Value = "Open" Then
If Cells(i, 43).Value < Cells(i, 46).Value Then
Rows(i).Copy Sheets("Open items").Rows(Lastrow)
i = i + 1
End If
End If
Next
Sheets("Observation Tracker").Select
Rows("1:1").Select
Selection.Copy
Sheets("Open Items").Select
Range("AI1").Select
Selection.End(xlToLeft).Select
ActiveSheet.Paste
Range("A1").Select
MsgBox "Open Items Extracted"
Application.ScreenUpdating = True
End Sub
I want all open items with dates passed by to populate in the Open Item worksheet
This line here Rows(i).Copy Sheets("Open items").Rows(Lastrow) will always paste to the same row because you never increment lastrow. So as your code loops through the sheet the output is constantly being overwritten until the last match is made which is the only one you will see.
Rows(i).Copy Sheets("Open items").Rows(Lastrow)
lastrow = lastrow + 1
I don't think you need i = i + 1 either because your for loop is already incrementing i so you are skipping a line every time it gets there.
EDIT:
Here is what I came up with.
Sub OpenItems()
Dim i As Long
Dim lastrow As Long
Dim lastcol As Long
Dim pasteiter As Long
Application.ScreenUpdating = False
With Sheets("Open Items")
'This will clear the contents of Open Items
lastrow = .Cells(Rows.Count, 43).End(xlUp).Row
lastcol = .Cells.Find(What:="*", after:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
.Range(.Cells(2, 1), .Cells(lastrow, lastcol)).ClearContents
End With
pasteiter = 2 'Make sure we don't overwrite anything
With Sheets("Observation Tracker")
lastrow = .Cells(Rows.Count, "AQ").End(xlUp).Row
For i = 2 To lastrow
'Combined the two IF statements since we weren't using the outer else.
If (.Cells(i, 28).Value = "Open") And (.Cells(i, 43).Value <= .Cells(i, 46).Value) Then
.Rows(i).Copy Sheets("Open Items").Rows(pasteiter)
pasteiter = pasteiter + 1
End If
Next
.Rows(1).Copy Sheets("Open Items").Rows(1) 'Grab the headers
End With
Application.ScreenUpdating = True
MsgBox "Open Items Extracted"
'I'm not sure what your last bits of code did I removed them.
End Sub
If open items sheet is blank just put something in the first row the first time you run this otherwise you will get a with/object error. Should only occur the first time though.
I removed all your selections and activates, they aren't necessary, slow things down, and obfuscate your code. I also removed lastrowa as it didn't appear to be used.
Good Morning,
I have a database of safety data sheets for the benefit of COSHH, i am trying to create a function in which the user can enter a date into "H7" and any entried with dates less than that one will have the entire row transferred into sheet2.
the code i have written is as below
Sub checkdatasheets()
Dim datefrom As Variant
'select first entry
Sheet1.Range("E2").Select
'continue until an empty cell is reached
Do Until ActiveCell.Offset(1, 0).Value = ""
If ActiveCell.Value = "" Then GoTo skipto:
'aquire date parameter
datefrom = Sheet1.Range("H7")
'if revision date is less than the date parameter copy and add to sheet2
If ActiveCell.Value <= datefrom Then
ActiveCell.Rows.EntireRow.Copy
Sheets("Sheet2").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
'move onto next cell
ActiveCell.Offset(1, 0).Select
Loop
skipto: MsgBox "Missing Data Sheet"
End Sub
The issue i am having is that this code takes certain rows but lots of rows are missed, even though they are less than the datefrom variable?
Thank you in advance for your help, any feedback on the writing of my code would be appreciated.
You should avoid using select and also reference your sheets better. Something like code below should work better allready:
Sub checkdatasheets2()
For X = 2 To Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row
If Sheets(1).Cells(X, 5).Value < Sheets(1).Cells(7, 8).Value Then
Sheets(1).Rows(X).Copy Destination:=Sheets(2).Range("A" & Sheets(2).Cells(Sheets(2).Rows.Count, 5).End(xlUp).Row + 1)
End If
Next X
End Sub
Import the below code in the change event of the sheet which you will import the date.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sDate As Date
Dim LastRow1 As Long, LastRow2 As Long, i As Long
If Not Intersect(Target, Range("A1")) Is Nothing Then
If IsDate(Target.Value) Then
sDate = CDate(Target.Value)
LastRow1 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRow1
If CDate(Sheet1.Range("A" & i).Value) < sDate Then
LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
Sheet1.Rows(i).Copy Sheet2.Rows(LastRow2 + 1)
End If
Next i
Else
MsgBox "Please insert a valid date."
End If
End If
End Sub
Sheet 1 (includes the date)
Sheet 2 (Results)
I'm working on a macro that selects a random series of employee id numbers for random testing. The code I have works well except the first number returned is always the same. For example, if my ID numbers are 1-100 and I want 10 random numbers, the first number will always be 1 and then at random after that.
As an extra challenge, is it possible to make it where the same numbers won't be selected until the list has been cycled through?
Here is the code that I'm using.
Sub Macro1()
'
'
'
'
Dim CountCells
Dim RandCount
Dim LastRow
Dim Counter1
Dim Counter2
Worksheets.Add().Name = "Sheet1"
Worksheets("Employee ID#").Select
Range("a2:A431").Select
Selection.Copy
Worksheets("Sheet1").Select
Selection.PasteSpecial
Worksheets("Sheet1").Select
Range("A1").Select
CountCells = WorksheetFunction.Count(Range("A:A")) 'quantity of random numbers to pick from
If CountCells = 0 Then Exit Sub
On Error Resume Next
Application.DisplayAlerts = False
RandCount = Application.InputBox(Prompt:="How many random numbers do you want?", _
Title:="Random Numbers Selection", Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
RandCount = Int(RandCount)
If Int(RandCount) <= 0 Or RandCount = False Then Exit Sub
If RandCount > CountCells Then
MsgBox "Requested quantity of numbers is greater than quantity of available data"
Exit Sub
End If
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
'clear working area
Range("B:C").ClearContents
'clear destination area
Range("Sheet2!A:A").ClearContents
'create index for sort use
Range("B1") = 1
Range(Cells(1, 2), Cells(LastRow, 2)).DataSeries , Step:=1
'create random numbers for sort
Range("C1") = "=RAND()"
Range("C1").Copy Range(Cells(1, 3), Cells(LastRow, 3))
'randomly sort data
Range(Cells(1, 1), Cells(LastRow, 3)).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'data has been sorted randomly, cells in column A, rows 1 through the quantity desired will be chosen
Counter1 = 1
Counter2 = 1
Do Until Counter1 > RandCount
If IsNumeric(Cells(Counter2, 1).Value) And Cells(Counter2, 1).Value <> Empty Then
Range("Sheet2!A" & Counter1) = Cells(Counter2, 1).Value
Counter1 = Counter1 + 1
'Selection.ClearContents
End If
Counter2 = Counter2 + 1
Loop
'resort data into original order and clear working area
Range(Cells(1, 1), Cells(LastRow, 3)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("B:C").ClearContents
Sheets("Sheet2").Select
'Sheets("Sheet2").PrintOut
End Sub
Thanks in advance for any help.
To get a different first number, simply add a line that says Randomize at the start of your function.
You could load the list of employees into an array and then when one is selected, remove the employee from the array so they can't be selected again.
-Edit-
I came up with this bit of code that should work for you. It loads the employee ID#s into an array so you don't have to deal with selecting and rearranging cells which is a slow operation. The code then picks employees from the array of all the employees and adds them to an array of employees to check. It then removes the employee from the array of all the employees so that they cannot be picked again. Once the code has selected the needed number of employees to check, it writes them into the desired sheet.
Sub SelectRandomEntries()
Dim WSEmp As Worksheet
Dim WSCheckedEmps As Worksheet
Dim AllEmps() As Long 'An array to hold the employee numbers
'Assuming Column A is an integer employee #
Dim CheckedEmps() As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim RandCount As Long
Dim RandEmp As Long
Dim i As Long
'Set the worksheets to variables. Make sure they're set to the appropriate sheets in YOUR workbook.
Set WSEmp = ThisWorkbook.Worksheets("Employee ID#") 'Sheet with all employees
Set WSCheckedEmps = ThisWorkbook.Worksheets("Checked Employees") 'Sheet with checked employees
FirstRow = 1
LastRow = WSEmp.Cells(WSEmp.Rows.Count, "A").End(xlUp).Row 'Find the last used row in a ColumnA
Randomize 'Initializes the random number generator.
'Load the employees into an array
ReDim AllEmps(FirstRow To LastRow) 'Make the array large enough to hold the employee numbers
For i = FirstRow To LastRow
AllEmps(i) = WSEmp.Cells(i, 1).Value
Next
'For this example, I sent RandCount to a random number between the first and last entries.
'Rnd() geneates a random number between 0 and 1 so the rest of line converts it to a usable interger.
RandCount = Int((LastRow - FirstRow + 1) * Rnd() + FirstRow)
MsgBox (RandCount & "will be checked")
ReDim CheckedEmps(1 To RandCount)
'Check random employees in the array
For i = 1 To RandCount
RandEmp = Int((LastRow - FirstRow + 1) * Rnd() + FirstRow) 'pick a random employee to check
If IsNumeric(AllEmps(RandEmp)) And AllEmps(RandEmp) <> Empty Then 'If the emp# is valid
CheckedEmps(i) = AllEmps(RandEmp) 'Move the employee to the checked employee list.
AllEmps(RandEmp) = Empty 'Clear the employee from the full list so they can't get picked again
Else
i = i - 1 'If you checked a RandEmp that wasn't suitable, you'll need to check another one.
End If
Next
'Write the employees to the results sheet
For i = 1 To RandCount
WSCheckedEmps.Cells(i, 1) = CheckedEmps(i)
Next i
End Sub
You may need to add checks that are relevant specifically to your data set (I just used a handful of random integers) and you'll want to re-implement a way for people to choose how many employees to check.