Home

VBA macro

%3CLINGO-SUB%20id%3D%22lingo-sub-655364%22%20slang%3D%22en-US%22%3EVBA%20macro%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-655364%22%20slang%3D%22en-US%22%3E%3CP%3EI%20have%20been%20working%20on%20revamping%20my%20works%20reporting%20system%20and%20I%20have%20been%20able%20to%20make%20a%20lot%20of%20improvements%20in%20the%20past%20month.%20However%2C%20there%20is%20one%20task%20that%20continues%20to%20stump%20me.%20Duplicate%20Entries.%20I%20have%20used%20CF%20to%20flag%20them%20but%20I%20want%20them%20to%20SUM%20and%20delete%20the%20Duplicate%20entries%20after%20the%20SUM.%20Found%20this%20VBA%20macro%20that%20is%20really%20close%20to%20what%20I%20need%3A%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3ESub%20Duplicate()%3C%2FP%3E%3CP%3EMsgBox%20%22Skript%20is%20Running%22%3C%2FP%3E%3CP%3EDim%20R%20As%20Range%3CBR%20%2F%3EDim%20Dic%20As%20Variant%3CBR%20%2F%3EDim%20arr%20As%20Variant%3CBR%20%2F%3EOn%20Error%20Resume%20Next%3CBR%20%2F%3ExTitleId%20%3D%20%22Combining%20Duplicate%20rows%20and%20sum%20values%22%3CBR%20%2F%3ESet%20R%20%3D%20Application.Selection%3CBR%20%2F%3ESet%20R%20%3D%20Application.InputBox(%22Range%22%2C%20xTitleId%2C%20R.Address%2C%20Type%3A%3D8)%3CBR%20%2F%3ESet%20Dic%20%3D%20CreateObject(%22Scripting.Dictionary%22)%3CBR%20%2F%3Earr%20%3D%20R.Value%3CBR%20%2F%3EFor%20i%20%3D%201%20To%20UBound(arr%2C%201)%3CBR%20%2F%3EDic(arr(i%2C%201))%20%3D%20Dic(arr(i%2C%201))%20%2B%20arr(i%2C%202)%3CBR%20%2F%3ENext%3CBR%20%2F%3EApplication.ScreenUpdating%20%3D%20False%3CBR%20%2F%3ER.ClearContents%3CBR%20%2F%3ER.Range(%22A1%22).Resize(Dic.Count%2C%201)%20%3D%20Application.WorksheetFunction.Transpose(Dic.keys)%3CBR%20%2F%3ER.Range(%22B1%22).Resize(Dic.Count%2C%201)%20%3D%20Application.WorksheetFunction.Transpose(Dic.items)%3CBR%20%2F%3EApplication.ScreenUpdating%20%3D%20True%3C%2FP%3E%3CP%3EEnd%20Sub%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EHowever%2C%20I%20don't%20want%20a%20range%20I%20want%20it%20to%20look%20at%20Column%20H%20to%20find%20the%20duplicates%20and%20I%20want%20it%20to%20SUM%20Column%20J%20when%20they%20find%20the%20duplicates.%20Then%20I%20need%20it%20to%20delete%20the%20Duplicate%20entry%20Rows.%20Any%20help%20is%20appreciated.%26nbsp%3B%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-655364%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E%3CLINGO-SUB%20id%3D%22lingo-sub-658621%22%20slang%3D%22en-US%22%3ERe%3A%20VBA%20macro%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-658621%22%20slang%3D%22en-US%22%3E%3CP%3EI've%20been%20working%20away%20at%20this%20for%20some%20time%20now%20and%20I%20have%20gotten%20closer%20and%20I%20think%20I%20have%20found%20a%20workaround%20for%20handling%20separate%20cell%20combination.%20But%20I%20am%20having%20issues%20making%20the%20second%20half%2C%20the%20Dup%20Destroyer%2C%20selecting%20the%20range%20I%20need%20it%20to.%20The%20original%20Macro%20I%20copied%20was%20designed%20for%20a%20Selection.%20I%20am%20needing%20it%20to%20be%20locked%20to%20a%20rank%20J1%3AK121.%20and%20there%20is%20nothing%20else%20it%20needs%20to%20be%20used%20for.%20The%20other%20part%20I%20haven't%20been%20able%20to%20figure%20out%20is%20having%20it%20delete%20lines%20with%20no%20data%20in%20them.%20It%20could%20test%20K2%3AK121%20for%20cells%20with%20no%20data%20and%20then%20remove%20the%20corresponding%20Row.%20Here%20is%20the%20Macro%20I%20have%20as%20of%20current.%20Any%20help%20is%20greatly%20appreciated!%20Thank%20you%20for%20your%20time!%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3ESub%20MoveAndRemove()%3C%2FP%3E%3CP%3EColumns(%22J%3AJ%22).Select%3CBR%20%2F%3ESelection.Insert%20Shift%3A%3DxlToRight%2C%20CopyOrigin%3A%3DxlFormatFromLeftOrAbove%3CBR%20%2F%3ERange(%22H1%22).Select%3CBR%20%2F%3E%3CBR%20%2F%3ERange(%22H1%3AH121%22).Select%3CBR%20%2F%3ESelection.Copy%3CBR%20%2F%3ERange(%22J1%22).Select%3CBR%20%2F%3ESelection.PasteSpecial%20Paste%3A%3DxlPasteValues%2C%20Operation%3A%3DxlNone%2C%20SkipBlanks%20_%3CBR%20%2F%3E%3A%3DFalse%2C%20Transpose%3A%3DFalse%3CBR%20%2F%3ERange(%22H121%22).Select%3CBR%20%2F%3E%3CBR%20%2F%3ERange(%22H1%3AH121%22).Select%3CBR%20%2F%3ERange(%22H121%22).Activate%3CBR%20%2F%3EApplication.CutCopyMode%20%3D%20False%3CBR%20%2F%3ESelection.ClearContents%3CBR%20%2F%3ERange(%22J1%22).Select%3CBR%20%2F%3E%3CBR%20%2F%3EDim%20R%20As%20Range%3CBR%20%2F%3EDim%20Dic%20As%20Variant%3CBR%20%2F%3EDim%20arr%20As%20Variant%3CBR%20%2F%3EOn%20Error%20Resume%20Next%3CBR%20%2F%3ExTitleId%20%3D%20%22Dup%20Destroyer%22%3CBR%20%2F%3ESet%20R%20%3D%20Range(%22J2%3AK121%22).Select%3CBR%20%2F%3ESet%20R%20%3D%20Application.InputBox(%22Range%22%2C%20xTitleId%2C%20R.Address%2C%20Type%3A%3D8)%3CBR%20%2F%3ESet%20Dic%20%3D%20CreateObject(%22Scripting.Dictionary%22)%3CBR%20%2F%3Earr%20%3D%20R.Value%3CBR%20%2F%3EFor%20i%20%3D%201%20To%20UBound(arr%2C%201)%3CBR%20%2F%3EDic(arr(i%2C%201))%20%3D%20Dic(arr(i%2C%201))%20%2B%20arr(i%2C%202)%3CBR%20%2F%3ENext%3CBR%20%2F%3EApplication.ScreenUpdating%20%3D%20False%3CBR%20%2F%3ER.ClearContents%3CBR%20%2F%3ER.Range(%22A1%22).Resize(Dic.Count%2C%201)%20%3D%20Application.WorksheetFunction.Transpose(Dic.keys)%3CBR%20%2F%3ER.Range(%22B1%22).Resize(Dic.Count%2C%201)%20%3D%20Application.WorksheetFunction.Transpose(Dic.items)%3CBR%20%2F%3EApplication.ScreenUpdating%20%3D%20True%3C%2FP%3E%3CP%3ERange(%22J1%3AJ121%22).Select%3CBR%20%2F%3ESelection.Copy%3CBR%20%2F%3ERange(%22H1%22).Select%3CBR%20%2F%3ESelection.PasteSpecial%20Paste%3A%3DxlPasteValues%2C%20Operation%3A%3DxlNone%2C%20SkipBlanks%20_%3CBR%20%2F%3E%3A%3DFalse%2C%20Transpose%3A%3DFalse%3CBR%20%2F%3ERange(%22J121%22).Select%3CBR%20%2F%3E%3CBR%20%2F%3ERange(%22J1%3AJ121%22).Select%3CBR%20%2F%3ERange(%22J121%22).Activate%3CBR%20%2F%3EApplication.CutCopyMode%20%3D%20False%3CBR%20%2F%3ESelection.ClearContents%3CBR%20%2F%3ESelection.EntireColumn.Delete%3C%2FP%3E%3CP%3EEnd%20Sub%3C%2FP%3E%3C%2FLINGO-BODY%3E
Zwatson
New Contributor

I have been working on revamping my works reporting system and I have been able to make a lot of improvements in the past month. However, there is one task that continues to stump me. Duplicate Entries. I have used CF to flag them but I want them to SUM and delete the Duplicate entries after the SUM. Found this VBA macro that is really close to what I need:

 

Sub Duplicate()

MsgBox "Skript is Running"

Dim R As Range
Dim Dic As Variant
Dim arr As Variant
On Error Resume Next
xTitleId = "Combining Duplicate rows and sum values"
Set R = Application.Selection
Set R = Application.InputBox("Range", xTitleId, R.Address, Type:=8)
Set Dic = CreateObject("Scripting.Dictionary")
arr = R.Value
For i = 1 To UBound(arr, 1)
Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 2)
Next
Application.ScreenUpdating = False
R.ClearContents
R.Range("A1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
R.Range("B1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)
Application.ScreenUpdating = True

End Sub

 

However, I don't want a range I want it to look at Column H to find the duplicates and I want it to SUM Column J when they find the duplicates. Then I need it to delete the Duplicate entry Rows. Any help is appreciated. 

1 Reply
Highlighted

I've been working away at this for some time now and I have gotten closer and I think I have found a workaround for handling separate cell combination. But I am having issues making the second half, the Dup Destroyer, selecting the range I need it to. The original Macro I copied was designed for a Selection. I am needing it to be locked to a rank J1:K121. and there is nothing else it needs to be used for. The other part I haven't been able to figure out is having it delete lines with no data in them. It could test K2:K121 for cells with no data and then remove the corresponding Row. Here is the Macro I have as of current. Any help is greatly appreciated! Thank you for your time!

 

Sub MoveAndRemove()

Columns("J:J").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Select

Range("H1:H121").Select
Selection.Copy
Range("J1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("H121").Select

Range("H1:H121").Select
Range("H121").Activate
Application.CutCopyMode = False
Selection.ClearContents
Range("J1").Select

Dim R As Range
Dim Dic As Variant
Dim arr As Variant
On Error Resume Next
xTitleId = "Dup Destroyer"
Set R = Range("J2:K121").Select
Set R = Application.InputBox("Range", xTitleId, R.Address, Type:=8)
Set Dic = CreateObject("Scripting.Dictionary")
arr = R.Value
For i = 1 To UBound(arr, 1)
Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 2)
Next
Application.ScreenUpdating = False
R.ClearContents
R.Range("A1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
R.Range("B1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)
Application.ScreenUpdating = True

Range("J1:J121").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("J121").Select

Range("J1:J121").Select
Range("J121").Activate
Application.CutCopyMode = False
Selection.ClearContents
Selection.EntireColumn.Delete

End Sub

Related Conversations
Tabs and Dark Mode
cjc2112 in Discussions on
16 Replies
flashing a white screen while open new tab
cntvertex in Discussions on
11 Replies
How to Prevent Teams from Auto-Launch
chenrylee in Microsoft Teams on
28 Replies
*Updated 9/3* Syncing in Microsoft Edge Preview Channels
Elliot Kirk in Articles on
217 Replies