I have this procedure that I have copied from a couple of forums and adapted to my needs. The procedure removes duplicates perfectly than copies my formatting as needed.
However, it is removing the new records that are duplicates and leaving me the old date.
I have a sheet with rows of data for loans and their statuses. The statuses change everyday and so I copy the new data to the next available row and then run the procedure. The procedure is leaving the old date and removing the new data as the duplicate. How can I modify so that it recognizes that the new pasted data are the duplicated records I want to keep and removes the old date as the duplicates?
Sub RemoveDuplicateRows()
'Demonstrates how to use the VBA RemoveDuplicates method to remove
'the duplicate rows from a particular column in a range of data.
Dim MyRange As Range
Dim LastRow As Long
LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Set MyRange = ActiveSheet.Range("A11:T" & LastRow)
MyRange.RemoveDuplicates Columns:=2, Header:=xlYes
Range("A11:T1000" & LastRow).Select
Selection.Copy
'pastes range with duplicates removed
Range("A11:T1000").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A11:T11").Select
Selection.Copy
'Copies formatiing
Range("A12:T1000").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWindow.SmallScroll Down:=24
GoToEnd
End Sub
I was able to resolve by Tim Williams' suggestion to sort data in such a way that I had to get the new data above the old data. I accomplished this by using a helper column to timestamp the data.
I am not an expert (at all) so I am sure it can be written much more efficiently, but here is the full code for anyone seeking this topic:
Sub RemoveDuplicateRows()
'Demonstrates how to use the VBA RemoveDuplicates method to remove
'the duplicate rows from a particular column in a range of data.
Dim MyRange As Range
Dim LastRow As Long
ActiveSheet.Unprotect
Application.EnableEvents = False
Dim r As Range
Set r = ActiveSheet.Range("$a$10:$u$1000")
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode
Then
ActiveSheet.ShowAllData
End If
Range("a11:u1000").Select
Selection.Sort Key1:=Range("U11"), Order1:=xlDescending, Key2:=Range("B11") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Set MyRange = ActiveSheet.Range("A11:U" & LastRow)
MyRange.RemoveDuplicates Columns:=2, Header:=xlYes
Range("A11:U" & LastRow).Select
Selection.Copy
'pastes range with duplicates removed
Range("A11:U1000").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A11:U11").Select
Selection.Copy
'Copies formatiing
Range("A12:U1000").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWindow.SmallScroll Down:=24
GoToEnd
Application.EnableEvents = True
End Sub
Related
I am trying to write a code that it filters out by production day.
It then filters for the different lines (field 3) (Line A/B, Line C, etc)
and it then takes the item numbers for those and pastes it into another sheet.
However, now when I change the day criteria to another day - for example day 6...
not all the lines which existed in Day 1 exist.
So if I replace field 1, criteria one with 6 instead of 1, it messes up the sheet because Line A/B does not exist for Day 6.
how can i tweak this code so that even if that specific line filter does not exist for a certain day - it ignores or doesn't mess up the rest of the sheet.
Any help would be greatly appreciated!
Range("D7:O7").Select
Selection.AutoFilter
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=10, Criteria1:=Array( _
"1,120.67", "1,200.00", "10,472.00", "121.00", "185.00", "190.50", "24.00", "241.50", _
"30.00", "436.00", "450.00", "465.00", "500.00", "525.00", "54.00", "60.00", "630.00", _
"71.00", "756.00", "893.00", "90.00", "984.50", "991.00"), Operator:= _
xlFilterValues
ActiveWindow.ScrollColumn = 1
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=1, Criteria1:="1"
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=3, Criteria1:="A/B"
Range("E8:E52").Select
Selection.Copy
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Production Schedule - Daily").Select
Range("I12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("July Production for Open Orders").Select
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=3, Criteria1:="=B/C", _
Operator:=xlOr, Criteria2:="=Line B"
Range("E8:E52").Select
Application.CutCopyMode = False
Selection.Copy
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Production Schedule - Daily").Select
Range("U12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("July Production for Open Orders").Select
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=3, Criteria1:="Line C"
Range("E8:E52").Select
Application.CutCopyMode = False
Selection.Copy
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Production Schedule - Daily").Select
Range("AG12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("July Production for Open Orders").Select
ActiveSheet.Range("$D$7:$O$52").AutoFilter Field:=3, Criteria1:="Line O"
Range("E8:E52").Select
Application.CutCopyMode = False
Selection.Copy
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Production Schedule - Daily").Select
Range("AS12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("July Production for Open Orders").Select
ActiveSheet.ShowAllData
Sheets("Production Schedule - Daily").Select
Range("E1").Select
You can improve your code by using some variables to refer to the sheets and ranges you're using, and by extracting the "copy and paste visible cells only" steps to a separate Sub which you can call from your main code. Use some error handling to take care of cases where all rows are filtered and there are no visible cells to copy.
Sub Tester()
Dim rngTable As Range, rngHdrs As Range, rngCopy As Range, ws As Worksheet
Dim rngVis As Range, wsPS As Worksheet
Set ws = ActiveSheet 'source sheet
Set wsPS = ws.Parent.Worksheets("Production Schedule - Daily")
Set rngTable = ws.Range("D7:O52") 'whole table
Set rngHdrs = rngTable.Rows(1) 'headers
Set rngCopy = rngTable.Columns(2).Offset(1, 0). _
Resize(rngTable.Rows.Count - 1) 'Col E, data only
rngHdrs.AutoFilter
rngTable.AutoFilter Field:=10, Criteria1:=Array( _
"1,120.67", "1,200.00", "10,472.00", "121.00", "185.00", "190.50", "24.00", "241.50", _
"30.00", "436.00", "450.00", "465.00", "500.00", "525.00", "54.00", "60.00", "630.00", _
"71.00", "756.00", "893.00", "90.00", "984.50", "991.00"), Operator:= _
xlFilterValues
rngTable.AutoFilter Field:=1, Criteria1:="1"
rngTable.AutoFilter Field:=3, Criteria1:="A/B"
CopyVisible rngCopy, wsPS.Range("I12")
rngTable.AutoFilter Field:=3, Criteria1:="=B/C", Operator:=xlOr, Criteria2:="=Line B"
CopyVisible rngCopy, wsPS.Range("U12")
rngTable.AutoFilter Field:=3, Criteria1:="Line C"
CopyVisible rngCopy, wsPS.Range("U12")
rngTable.AutoFilter Field:=3, Criteria1:="Line O"
CopyVisible rngCopy, wsPS.Range("AS12")
ws.ShowAllData
wsPS.Select
wsPS.Range("E1").Select
End Sub
'copy all visible cells from `rngFrom` and paste as values to `rngTo`
' Return False if no visible cells were found
Sub CopyVisible(rngFrom As Range, rngTo As Range)
Dim vis As Range
On Error Resume Next 'ignore error if no cells found
Set vis = rngFrom.SpecialCells(xlCellTypeVisible)
On Error GoTo 0 'stop ignoring errors
If Not vis Is Nothing Then
vis.Copy
rngTo.Cells(1).PasteSpecial Paste:=xlPasteValues
End If
End Sub
Most of our orders go through our original packing team who use this consolidated format for packing orders per customer.
A new team requires each item to be on a separate line, so each Sales Order needs five rows, one for each type of widget we sell. They need it to look like this:
I recorded a macro of the copy/paste commands to log the first order:
Sub GrabOrders()
'
' GrabOrders Macro
'
'
Sheets("Raw Data").Select
Range("B2").Select
Selection.Copy
Sheets("Ship Sheet").Select
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("A2:A6"), Type:=xlFillDefault
Range("A2:A6").Select
Sheets("Raw Data").Select
Range("F1:J1").Select
Selection.Copy
Sheets("Ship Sheet").Select
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Raw Data").Select
Range("F2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Ship Sheet").Select
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
I now need the cell-to-be-copied (on the original format tab) to move down one row to the next order and for the pasting on the new format tab to begin five rows down so as not to overwrite data from the previous order.
The Item Name will remain fixed (in F1, G1, etc. on the original tab) while the other cells-to-be-copied will be moving. I need this to loop until it reaches a blank Sales Order cell.
You should start by removing all of the select statements in your code.
Range("B2").Select
Selection.Copy
Can be simplified to
Sheets("Raw Data").Range("B2").Copy
When you are writing loops you need to start by defining the range in which your data will be located. You will learn more about how to do this when you read about avoiding select statements. You're going to want to want to define the range for the data which you pull from and to avoid rewriting your code I'll define another last row within the loop to account for the autofill command you have opted to use.
The below I believe works for what you are trying to achieve but you should try to go back and remove the select statements.
Sub GrabOrders()
Dim lrdata As Long
lrdata = Sheets("Raw Data").Range("A" & Rows.Count).End(xlUp).Row ' choose whichever column contains the last row of your data here
Dim i As Long
For i = 2 To lrdata ' for 2 to the number of rows in our data
Dim lastrow2 As Long
lastrow2 = Sheets("Ship Sheet").Range("a" & Rows.Count).End(xlUp).Row + 1 ' get the last row in your ship sheet then add one to avoid copying over your data
' from here, every instace of "2" you are going to change it to " & i "
Sheets("Raw Data").Select
Sheets("Raw Data").Range("B" & i).Select
Selection.Copy
Sheets("Ship Sheet").Select
Sheets("Ship Sheet").Range("A" & lastrow2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("A" & lastrow2, "A" & lastrow2 + 4), Type:=xlFillDefault ' plus five to your last row since there are only 5 colors you need to get data for
Sheets("Raw Data").Select
Range("F1:J1").Select
Selection.Copy
Sheets("Ship Sheet").Select
Range("G" & lastrow2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Raw Data").Select
Sheets("Raw Data").Range("F" & i, "J" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Ship Sheet").Select
Sheets("Ship Sheet").Range("H" & lastrow2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Next i
End Sub
I'm creating a button that will allow the user to add a new record to the very top of the list, and move all records one row below (to keep the newest records at the top). The code I've written works perfectly as-is. However, I have to write a lot of repeating code to apply it to all rows within the range. Here is my code:
Sub Test2()
' Stop screen from following macro actions & disable alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' If more than 1 record, copy all rows and paste 1 row below, apply merged cell formatting, clear data from first row, and re-enable alerts/screen updating
If WorksheetFunction.CountA(Range("AM5:AN21")) > 1 Then
Range("CW28:DJ28").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("CW29:DJ29").Select
ActiveSheet.Paste
Range("CW28:DJ28").Select
Selection.Copy
Range("CW29").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
...
Range("CW1277").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("CW28:DJ28").Select
Selection.ClearContents
Range("CW28:CX28").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' If only 1 record, copy first row and paste 1 row below, apply merged cell formatting, clear data from first row, and re-enable alerts/screen updating
ElseIf WorksheetFunction.CountA(Range("AM5:AN21")) = 1 Then
Range("CW28:DJ28").Select
Selection.Copy
Range("CW29:DJ29").Select
ActiveSheet.Paste
Range("CW28:DJ28").Select
Selection.Copy
Range("CW29").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
...
Range("CW1277").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("CW28:DJ28").Select
Selection.ClearContents
Range("CW28:CX28").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' If zero records, re-enable alerts/screen updating
Else
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
End Sub
As you can see, the two spots where the "..." I need to apply to rows 29 through 1277. I know there's got to be a better way to do this with For ... Next, but what I've tried hasn't worked (code that I used is below, it would give me an error saying I can't do that to merged cells, even though my current code works).
Dim rng As Range: Set rng = Application.Range("CW28:CX1277")
Dim i As Integer
For i = 1 To 1248
rng.Cells(RowIndex:=i, ColumnIndex:="CW").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next
I know my entire issue is that we have merged cells, but we need to keep them if at all possible. Knowing that my current, repetitive coding works... is there a way to make the For ... Next function work?
What I understand of your code is that you copy the format of line N to line N+1 for columns CW to DJ, from lines 28 to 1277, by block.
(I strongly suppose it is not as much simple).
What you could do is (I replace your 28 by beginRow) :
dim beginRow as long, endRow as long
dim strRange as string
beginRow=28
while (beginRow<<1277)
strRange = "CW" & beginRow & ":DJ" & beginRow
Range(strRange).select
endRow=Selection.End(xlDown).row
strRange = "CW" & beginRow & ":DJ" & endRow
Range(strRange).Copy
strRange = "CW" & (beginRow+1) & ":DJ" & (endRow+1)
Range(strRange).Select
ActiveSheet.Paste
strRange = "CW" & (beginRow) & ":DJ" & (beginRow+1)
Range(strRange).Copy
Range("CW" & (beginRow+1)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
' find next block
beginRow=Range("CW" & (endRow+1)).End(xlDown).row
wend
Could this help ?
Pierre.
I figured it out!
Dim rng As Range
Dim cell As Range
Range("CW28:DJ28").Select
Selection.Copy
Set rng = Range("CW29:1277")
For Each cell In rng.Cells
cell.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next cell
Application.CutCopyMode = False
Now, I need to focus on how to get rid of .Select and .Activate throughout my code. Thank you so much for your help, all!
Good day,
I could only find examples where the tables are quite simple and the data minimal. I'm sitting with 36 makes, and up to 3 072 variants on the below data which I need sorted out.
The below col A through E is an extract of my data, with col G through I, the selections I need to make. To explain.
Blockquote
Col G: Should be a drop down with the values from Col C (which is easy and is done already)
Blockquote
Col H: If I now select Abarth in Col G, I only want the 500/695 or 124 displayed in a drop down, where I will choose 124
Blockquote
Col I: Similar to Col H, now only Abarth 124 related items should be displayed in the drop down
SOLVED! I have written macros to resolve as follows:
Sub SelectModel()
'
' SelecModel Macro
'
'
ActiveCell.Select
' Save the active cell to use later
Set myActiveCell = ActiveCell
Set myActiveWorksheet = ActiveSheet
Set myActiveWorkbook = ActiveWorkbook
ActiveCell.Copy Destination:=Sheets("2018MMCodes").Range("AU1")
Sheets("2018MMCodes").Select
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Columns("AV:AX").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Selections").Select
Range("A1").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$C$3257").RemoveDuplicates Columns:=2, Header:= _
xlYes
'Returns the user to the original sheet to enable just making a selection
myActiveWorkbook.Activate
myActiveWorksheet.Activate
myActiveCell.Activate
End Sub
Sub SelectVariant()
'
' SelectVariant Macro
'
'
ActiveCell.Select
' Save the active cell to use later
Set myActiveCell = ActiveCell
Set myActiveWorksheet = ActiveSheet
Set myActiveWorkbook = ActiveWorkbook
Selection.Copy
Sheets("2018MMCodes").Select
Range("AU3").Select
ActiveSheet.Paste
Columns("AV:AX").Select
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
Range("AV1:AX3257").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("'2018MMCodes'!Criteria"), Unique:=False
Selection.Copy
Sheets("Selections").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Returns the user to the original sheet to enable just making a selection
myActiveWorkbook.Activate
myActiveWorksheet.Activate
myActiveCell.Activate
End Sub
In my macro, i need to insert a formula in columns AA and AB, AB is empty so no problem there. Column AA has data which starts in AA10954, my problem is AA10954 changes each week as my data either increases or decrease as i import from another book, can someone help me to set the last empty cell before my data starts in AA?
Sub ClassVisit()
'
' ClassVisit Macro
'
'
Dim lr As Long
With ActiveWorkbook
With ActiveSheet
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
Range("AA2").Formula = "=IFERROR(VLOOKUP(A2,[Data.xlsb]Stores!$A:$AA,27,0),VLOOKUP(A2,'[Salesinfo.xlsb]Packs'!$C:$E,3,0))"
Range("AB2:AB" & lr).Formula = "=IFERROR(VLOOKUP(A2,Attribute!D:F,3,0),""Not Visited"")"
Range("AA2").Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A10953")
ActiveCell.Range("A1:A10953").Select
Range("AA2:AB" & lr).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.End(xlUp).Select
Application.CutCopyMode = False
ActiveCell.Offset(1, -26).Range("A1").Select
End With
End With
End Sub