I presently have a UserForm that feeds into a spreadsheet. I require that once the information is entered into the UserForm that a search is done within the spreadsheet for rows that match the same PRI, if so the previous information is deleted and the new information populated in the sheet. It is important that only the matching PRI numbers are removed and if the new submission as additional options than the previous it doesn't overwrite other rows. This is my present coding:
Private Sub CmdAdd_Click()
Dim ws As Worksheet
Dim info
Dim rw As Range
Dim n As Long
Dim r As Range
Const strPwd As String = "Transfer19"
ThisWorkbook.Unprotect Password:=strPwd
Set ws = Worksheets("Inventory")
With ws
'get all the tombstone info into an array
info = Array(Me.TxtFirst.Value, Me.TxtLast.Value, _
Me.TxtPRI.Value, Me.TxtGR.Value, _
Me.TxtLV.Value, Me.TxtLinguistic.Value, _
Me.TxtEmail.Value, Me.TxtResumeNum.Value, _
Me.TxtReason.Value, Me.TxtDate.Value)
.Unprotect Password:="Transfer19"
'get the first empty row...
Set rw = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow
'loop over the province and city controls
For n = 1 To 10
'get province and city values
p = Me.Controls("ListProv" & n).Value
c = Me.Controls("ListCity" & n).Value
If n = 1 Or p <> "" Then
rw.Cells(1).Resize(1, 10).Value = info
rw.Cells(11).Value = p
rw.Cells(12).Value = c
Set rw = rw.Offset(1, 0)
End If
Next n
.Protect Password:="Transfer19"
End With
ThisWorkbook.Protect Password:=strPwd
ThisWorkbook.Save
End Sub
This is what I tried which partially works. It finds the duplicates and replaces with the new information but it doesn't work with the present loop
'searching for duplicates
Set r = ws.Range("C:C").Find(Me.TxtPRI.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not r Is Nothing Then
MsgBox "Duplicate entry. The record is deleted and the new data is placed"
iRow = r.Row
End If
Related
What the code is supposed to do:
Remove all the duplicate data in specified data range
Inform the user how many duplicates have been deleted in total (I have done this by removing the duplicate data and removing the blank rows and subtracting the original data set amount by the remainder)
**Im struggling with this: run a second time, get a msgbox to appear and say "Number of duplicates = 0
"
Sub Delete_Duplicate()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim sh As Worksheet
Dim rn As Range
Set sh = ThisWorkbook.Sheets("Data")
Dim k As Long
Set rn = sh.UsedRange
k = rn.Rows.Count + rn.Row - 1
Range("A11:F11").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Range("$A$10:$F$57250").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5 _
, 6), Header:=xlYes
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
k = rn.Rows.Count + rn.Row - 1
response = MsgBox("Total Duplicate Rows Removed = " & 57250 - k & Chr(10) & "Continue?", _
vbYesNoCancel + vbQuestion, "MsgBox Demonstration")
Your code looks like a flying time bomb because it deletes indiscriminately.
Any duplicates on the ActiveSheet which could be any sheet in any open workbook.
Entire rows in which any blank cell is found within its UsedRange. This could easily be every single row in the worksheet.
I have re-written your code to make it less dangerous. Before running it please change the name of the worksheet in the line Set Sh = ThisWorkbook.Sheets("Duplicates") and make sure that the line Const Rstart As Long = 11 correctly defines the worksheet row in which the first duplicate or blank is to be looked for (the row immediately below whatever headers or captions your sheet may have). Observe that the code looks in column A for the last used row in the worksheet as well as for blank cells where the entire row is presumed blank.
Option Explicit
Sub Delete_Duplicates()
Const Rstart As Long = 11 ' first data row (excl captions)
Dim Sh As Worksheet
Dim Rend As Long
Dim Rn As Range
Dim k As Long
Dim Response As VbMsgBoxResult
Dim R As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set Sh = ThisWorkbook.Sheets("Duplicates")
With Sh
Rend = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rn = Range(.Cells(Rstart, "A"), .Cells(Rend, "F"))
Rn.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6)
k = Rend
Rend = .Cells(.Rows.Count, "A").End(xlUp).Row
k = k - Rend
' there can be only one blank row because
' others were removed as duplicates
R = Rn.Cells(1).End(xlDown).Row + 1
If R < Rend Then
.Rows(R).Delete
k = k + 1
End If
End With
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Response = MsgBox(k & " duplicate and blank rows were removed." & _
Chr(10) & "Continue?", _
vbYesNo Or vbQuestion, _
"MsgBox Demonstration")
If Response = vbYes Then Delete_Duplicates
End Sub
It's is possible to create a macro that do a mathematical sum?
I don't know how to explain. But I already saw another answers but I could not make work for me.
Here is what I trying to do:
I have this Worksheet
iTEM 1 [1]: https://i.stack.imgur.com/v7vXF.jpg
And I to put values as the image below. Make a search and make a mathematical sum in the "available" according with the group.
ITEM 2 [2]: https://i.stack.imgur.com/wQnxu.png
Here would be the result:
ITEM 3 [3]: https://i.stack.imgur.com/ify7J.png
To answer your question, tongue in cheek, Excel is very good at doing mathematical sums, and with the help of VBA it gains versatility. To prove the point, the code below doesn't only act upon your selection in the 'Update' sheet, it takes all the items in the 'Update' sheet and posts them to the 'Database' sheet. Click twice and it's done twice over. There is no break.
Option Explicit
Enum Nup ' Sheet Update
NupFirstDataRow = 2
NupName = 1 ' 1 = column A
NupGroup = 5
NupQty = 7
End Enum
Enum Ndt ' Sheet Data
NdtFirstDataRow = 2
NdtName = 1 ' 1 = column A
NdtGroup = 3
NdtQty ' = 4
NdtOffset = 3 ' NdtGroup + NdtOffset = Group2 column
End Enum
Sub UpdateQuantity()
' 09 Jan 2018
Dim WsUpdate As Worksheet ' Sheet where data are entered
Dim WsData As Worksheet ' Sheet where data are updated
Dim Rng As Range
Dim SearchRng As Range
Dim Itm As String ' an item's name
Dim Qty As Long ' Update quantity (designed for integers)
Dim Rt As Long ' target row in WsData
Dim Rl As Long ' last row in WsUpdate
Dim ClmOffset As Long ' helper
Dim R As Long ' row counter in WsUpdate
Dim Ct As Ndt ' column in WsData
Set WsUpdate = Worksheets("Update")
Set WsData = Worksheets("Database")
With WsData
Rl = .Cells(.Rows.Count, NupName).End(xlUp).Row
Set Rng = Range(.Cells(NdtFirstDataRow, NdtName), .Cells(Rl, NdtQty + NdtOffset))
End With
Application.ScreenUpdating = False
With WsUpdate
Rl = .Cells(.Rows.Count, NupName).End(xlUp).Row
For R = NupFirstDataRow To Rl
Itm = .Cells(R, NupName).Value
Set SearchRng = Range(Rng.Columns(NdtName), Rng.Columns(NdtName))
If CellAddress(Itm, SearchRng, Rt) Then
Itm = .Cells(R, NupGroup).Value
With WsData
Set SearchRng = Range(.Cells(R, NdtGroup), .Cells(R, NdtGroup + NdtOffset))
End With
If CellAddress(Itm, SearchRng, Ct) Then
Qty = Val(.Cells(R, NupQty).Value)
With WsData.Cells(Rt, Ct + 1)
Qty = Val(.Value) + Qty
.Value = Qty
End With
End If
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Private Function CellAddress(ByVal Itm As String, _
SearchRange As Range, _
Rc As Long) As Boolean
' 09 Jan 2018
' Rc is a return variable (either column or row = 0 if not found)
Dim ClmRng As Range
Dim Fnd As Range
Dim i As Long
With SearchRange
Set Fnd = .Find(What:=Itm, After:=.Cells(.Cells.Count), _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If Fnd Is Nothing Then
Rc = 0
MsgBox "Item """ & Itm & """ wasn't found.", _
vbInformation, "Update failed"
Else
Rc = IIf(.Rows.Count > 1, Fnd.Row, Fnd.Column)
CellAddress = True
End If
End With
End Function
The enumerations at the top of the code control which columns and rows are used. You can modify these numbers. Observe that the quantity columns in the Database must be adjacent to the Group columns. The only other place in the code you may have to change concerns the names of the two worksheets. The code must be in a standard code module in the same workbook.
I have a work book that I am trying to take some inserted data and save it on a new row for new data. But if the first cell of that entered data equals another cell in that same column than i want to over write that previously saved data with the newly entered data.
Sub SmartHBD_Save()
Application.ScreenUpdating = False
Dim StoredJobs As Worksheet
Dim JobNumber As Integer
JobNumber = Sheets("Stored Jobs").Range("B" & Rows.Count).End(xlUp).Row
Dim c As Range
For Each c In Sheets("Stored Jobs").Range("B4:B" & JobNumber)
Set StoredJobs = Worksheets("Stored Jobs")
If c.Value = B2 Then
StoredJobs.Range("B2:AO2").Copy
StoredJobs.Cells(JobNumber, 1).End(xlUp).PasteSpecial xlPasteValues
Else
StoredJobs.Range("B2:AO2").Copy
StoredJobs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).PasteSpecial xlPasteValues
End If
Next c
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I had it working to save data on a new row but when I tried to get it to overwrite data it stopped working.
Tested:
Sub SmartHBD_Save()
Dim StoredJobs As Worksheet
Dim lastRow As Long
Dim f As Range, theJob
Set StoredJobs = Worksheets("Stored Jobs")
lastRow = StoredJobs.Range("B" & Rows.Count).End(xlUp).Row
theJob = StoredJobs.Range("B2").Value
'find the current job if it exists
Set f = StoredJobs.Range("B4:B" & lastRow).Find(what:=theJob, lookat:=xlWhole)
'if not found, use the next empty row
If f Is Nothing Then Set f = StoredJobs.Range("B" & (lastRow + 1))
'B1:AO1 is *relative* to f.EntireRow
f.EntireRow.Range("B1:AO1").Value = StoredJobs.Range("B2:AO2").Value
End Sub
All, I have the following code, but I need to know how to amend it. I need a prompt or message box that asks me, which value in column A to look for. It should the find the corresponding value in Sheet1 Column A, and copy the Data from Column A to AL over to sheet2.
Here's my code:
Sub MM1()
Dim Check As Range, r As Long, lastrow2 As Long, lastrow As Long
Application.ScreenUpdating = False
lastrow = Worksheets("Sheet1").UsedRange.Rows.Count
lastrow2 = Worksheets("Sheet2").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
For r = lastrow To 2 Step -1
If Range("E" & r).Value = "Yes" Then
Rows(r).Cut Destination:=Worksheets("Sheet2").Range("A" & lastrow2 + 1)
lastrow2 = lastrow2 + 1
Else:
End If
Next r
Application.ScreenUpdating = True
End Sub
Also, this is to be a subset of code which will search for the exact row to insert at.
You don't need to do a manual loop through the rows in sheet1, just use VBA's native Find function. Also You're currently not getting user input, that can be achieved with an InputBox.
See the comments for details about the code.
This example copies the data from the first match:
Sub MM1()
Dim lastrowsheet2 As Long
' Use last cell in UsedRange for its row number,
' if row 1,2,... aren't used, then UsedRange will be shorter than you expect!
With ThisWorkbook.Sheets("Sheet2").UsedRange
lastrowsheet2 = .Cells(.Cells.Count).Row
End With
' Get user input for a search term
Dim userinput As String
userinput = InputBox("Enter a value to search for.", "Column A Search")
' Search for value
Dim findrange As Range
Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").Find(what:=userinput, lookat:=xlWhole, LookIn:=xlValues)
If findrange Is Nothing Then
MsgBox "No matching search results"
Else
lastrowsheet2 = lastrowsheet2 + 1
' Copy values in found row to sheet 2, in new last row
ThisWorkbook.Sheets("Sheet2").Range("A" & lastrowsheet2, "AL" & lastrowsheet2).Value _
= ThisWorkbook.Sheets("Sheet1").Range("A" & findrange.Row, "AL" & findrange.Row).Value
End If
End Sub
This example copies the data from the every match in the column:
Sub MM1()
' Speed improvements
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Use last cell in UsedRange for its row number,
' if row 1,2,... aren't used, then UsedRange will be shorter than you expect!
Dim lastrowsheet2 As Long
With ThisWorkbook.Sheets("Sheet2").UsedRange
lastrowsheet2 = .Cells(.Cells.Count).Row
' If sheet is completely empty, make sure data will be inserted on row 1 not 2
If lastrowsheet2 = 1 And .Cells(1).Value = "" Then lastrowsheet2 = 0
End With
' Get user input for a search term
Dim userinput As String
userinput = InputBox("Enter a value to search for.", "Column A Search")
' Search for value
Dim findrange As Range
Dim firstaddress As String
Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").Find(what:=userinput, lookat:=xlWhole, LookIn:=xlValues)
If findrange Is Nothing Then
MsgBox "No matching search results"
Else
firstaddress = findrange.Address
Do
lastrowsheet2 = lastrowsheet2 + 1
' Copy values in found row to sheet 2, in new last row
ThisWorkbook.Sheets("Sheet2").Range("A" & lastrowsheet2, "AL" & lastrowsheet2).Value _
= ThisWorkbook.Sheets("Sheet1").Range("A" & findrange.Row, "AL" & findrange.Row).Value
' Find next match
Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").FindNext(findrange)
' Loop until the Find has wrapped back around, or value not found any more
Loop While Not findrange Is Nothing And findrange.Address <> firstaddress
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The point of this code is to take user inputs from a "Remove Flags" tab in which the user puts an item number and what program it belongs to, filters the "Master List" tab by the item number and the program, then match the name of the flag to the column and delete the flag. However the offset is not working. It is instead deleting the header. When I step through it everything works fine until the line I marked with '*******.
I am fairly new to VBA and am self taught so any and all help is greatly appreciated. Thank you very much for your time.
EDIT: Removed "On Error Resume Next" and fixed some spelling errors. Current issue is with rng not having >1 rows when it is filtered and definitely has two rows (one row is the header, one row is the returned data.)
Sub RemoveFlag()
Dim cel As Range
Dim rg As Range
Dim d As Double
Dim i As Integer
Dim m As Integer
Dim n As Integer
Dim rng As Range
Dim wsMaster As Worksheet
Dim wsFlag As Worksheet
Set wsMaster = Worksheets("Master List")
Set wsFlag = Worksheets("Remove Flags")
i = 6
'If there is no data. Do nothing.
If wsFlag.Range("C6") = "" Then
wsFlag.Activate
Else
Application.ScreenUpdating = False
'Add Leading zeroes
wsFlag.Activate
Set rg = Range("C6")
Set rg = Range(rg, rg.Worksheet.Cells(Rows.Count, rg.Column).End(xlUp))
rg.NumberFormat = "#"
For Each cel In rg.Cells
If IsNumeric(cel.Value) Then
d = Val(cel.Value)
cel.Value = Format(d, "000000000000000000") 'Eighteen digit number
End If
Next
'Clear all the filters on the Master List tab.
wsMaster.Activate
If wsMaster.AutoFilterMode = True Then
wsMaster.AutoFilterMode = False
End If
'Loop through all lines of data
Do While wsFlag.Cells(i, 3).Value <> ""
'Filter by the SKU number
wsMaster.Range("A1").AutoFilter Field:=4, Criteria1:=wsFlag.Cells(i, 3).Value
'Filter by the Program
wsMaster.Range("A1").AutoFilter Field:=2, Criteria1:=wsFlag.Cells(i, 2).Value
'If the filter is not empty find the column of the flag
Set rng = wsMaster.UsedRange.SpecialCells(xlCellTypeVisible)
If (rng.Rows.Count > 1) Then
wsMaster.Range("A1:Z1").Find(wsFlag.Cells(i, 4), LookIn:=xlValues).Activate
n = ActiveCell.Column
Sheets("Master List").Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
m = ActiveCell.Row
Cells(m, n) = ""
wsFlag.Activate
wsFlag.Range(Cells(i, 2), Cells(i, 4)).ClearContents
Else
wsFlag.Activate
wsFlag.Range(Cells(i, 2), Cells(i, 4)).Copy
wsFlag.Range("F4").End(xlDown).Offset(1, 0).Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
wsFlag.Range(Cells(i, 2), Cells(i, 4)).ClearContents
End If
wsMaster.Activate
wsMaster.AutoFilterMode = False
i = i + 1
Loop
'Make sure the entire Master List tab is not highlighted and pull the 'highlighted cell' to A1 in both tabs.
wsMaster.Activate
wsMaster.Range("A1").Activate
wsFlag.Activate
Range("A1").Activate
'Unfreeze the screen
Application.ScreenUpdating = True
End If
End Sub
As #Zerk suggested, first set two Worksheet variables at top of code:
Dim wsMaster As Worksheet
Dim wsRemoveFlags As Worksheet
Set wsMaster = Worksheets("Master List")
Set wsRemoveFlags = Worksheets("Remove Flags")
Then replace all other instances of Worksheets("Master List") with wsMaster and Worksheets("Remove Flags") with wsRemoveFlags.
Sometimes it's easier to just loop through your rows and columns. Something like the following:
Replace everything between:
Do While wsFlag.Cells(i, 3).Value <> ""
...
Loop
with:
Do While wsFlag.Cells(i, 3).Value <> ""
Dim r As Long ' Rows
Dim c As Long ' Columns
Dim lastRow As Long
Dim found As Boolean
lastRow = wsMaster.Cells.SpecialCells(xlLastCell).Row
found = False
For r = 2 To lastRow ' Skipping Header Row
' Find Matching Program/SKU
If wsMaster.Cells(r, 2).Value = wsFlag.Cells(i, 2).Value _
And wsMaster.Cells(r, 3) = wsFlag.Cells(i, 3).Value Then
' Find Flag in Row
For c = 1 To 26 ' Columns A to Z
If wsMaster.Cells(r, c) = wsFlag.Cells(i, 4) Then
' Found Flag
wsMaster.Cells(r, c) = ""
found = True
Exit For ' if flag can be in more than one column, remove this.
End If
Next 'c
End If
Next 'r
If Not found Then
' Here is where you need to put code if Flag wsFlag.Cells(i, 4) not found.
End If
Loop