Excel VBA Combine Duplicates Keep Unique - vba

I have a dataset that I paste just below a table in which it extends to include it. I then combine all duplicate rows. However, I added two additional columns to the table that i would like to have notes in. However, when I later combine the duplicate rows, the newer row's blank cells overwrite any notes I had in there. Columns AC and AD are my notes cells. I have been trying to use a concatenate method to get around it overwriting it, however I found this awesome macro to combine duplicates but I cant for the life of me figure out how to write a line that would not delete my notes columns in the combine process! Any help would be greatly appreciated!!
Option Explicit
Sub removeDupesKeepLast()
Dim d As Long, dDQs As Object, ky As Variant
Dim r As Long, c As Long, vVALs As Variant, vTMP As Variant
'appTGGL bTGGL:=False 'uncomment this when you have finished debugging
Set dDQs = CreateObject("Scripting.Dictionary")
dDQs.comparemode = vbTextCompare
'step 1 - bulk load the values
With Worksheets("Master RFL Pipeline").Range("Table135") 'you should know what worksheet you are on
With .Cells(1, 1).CurrentRegion 'block of data radiating out from A1
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) 'step off the header row
vVALs = .Value 'use .Value2 if you do not have dates in unformatted cells
End With
End With
End With
'step 2 - build the dictionary
ReDim vTMP(UBound(vVALs, 2) - 1)
For r = LBound(vVALs, 1) To UBound(vVALs, 1)
For c = LBound(vVALs, 2) To UBound(vVALs, 2)
vTMP(c - 1) = vVALs(r, c)
Next c
dDQs.Item(vVALs(r, 1) & ChrW(8203)) = vTMP
Next r
'step 3 - put the de-duplicated values back into the array
r = 0
ReDim vVALs(1 To dDQs.Count, LBound(vVALs, 2) To UBound(vVALs, 2))
For Each ky In dDQs
r = r + 1
vTMP = dDQs.Item(ky)
For c = LBound(vTMP) To UBound(vTMP)
vVALs(r, c + 1) = vTMP(c)
Next c
Next ky
'step 4 - clear the destination; put the de-duplicated values back into the worksheet and reset .UsedRange
With Worksheets("Master RFL Pipeline").Range("Table135") 'you should know what worksheet you are on
With .Cells(1, 1).CurrentRegion 'block of data radiating out from A1
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) 'step off the header row
.ClearContents 'retain formatting if it is there
.Cells(1, 1).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
End With
End With
.UsedRange 'assert the UsedRange property (refreshes it)
End With
dDQs.RemoveAll: Set dDQs = Nothing
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.ScreenUpdating = bTGGL
.EnableEvents = bTGGL
.DisplayAlerts = bTGGL
.AutoRecover.Enabled = bTGGL 'no interruptions with an auto-save
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
.CutCopyMode = False
.StatusBar = vbNullString
End With
Debug.Print Timer
End Sub

Related

Excel VBA - merge cells if values in columns equals

I'm trying to figure out how to implement a macro to get results as follows:
I have no idea how to do it. This is what I've done so far.
I want to have additional column "Action" and if value in column "State" for e.g R1 is empty or "no_fix" then QM (green) else QA (red).
I have data with ~5000 rows
Hi, thanks it works as I expected. However, after testing of my data it turned out that I need to check additional conditions.
1.Additionally for QM and QA:
check in column G if value = "ST"
check in column H if value = 0
2.QA
check in column C if value = "No TC for LM" check in column D if
value = "no state" check in column E if value = "No IPIS" if any of
values = true then QA
Sub MergeSameCell()
'area
Dim Rng As Range, xCell As Range, Test As Range
Dim Rng1 As Range
Dim xRows As Integer
xTitleId = "Merge duplicated cells"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address,
Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
'If Rng.Cells(i, 1).Value > 0 And Rng.Cells(j, 1).Value > 0 Then
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
'WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
'Text = WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
i = j - 1
For Each Rng1 In Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
For Z = 1 To 13
'MsgBox i
'MsgBox j
If Rng1.Offset(Z, 1).Value = "no_to_fix" Or Rng1.Offset(Z,
1).Value
= "" Then
'WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1,
1)).Merge
Rng1.Cells.Offset(Z, 1).Interior.ColorIndex = 37
'MsgBox "supcio"
End If
Next
Next
Next
Next
WorkRng.VerticalAlignment = xlCenter
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
The following code will do the merging you want and, if I understand what you mean by the second part of the question, will set the first column to be either "QM" (if the fourth column is never anything other than blank or "no_fix") or "QA".
Code assumes you will use the InputBox to select a range containing four columns, the first being the column that will contain "QM" or "QA", the second being the column that is your "Req" column, and the fourth being your "State" column. (The code never looks at what is in the third column.)
Sub MergeSameCell()
Dim WorkRng As Range
xTitleId = "Merge duplicated cells"
Set WorkRng = Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim startRow As Long
Dim endRow As Long
Dim r As Long
Dim isQM As Boolean
'Use "startRow" to keep track of the start of each block
startRow = 1
With WorkRng
'Loop through each row in the selected range
For endRow = 1 To .Rows.Count
If .Cells(endRow + 1, 2).Value <> .Cells(startRow, 2).Value Then
'Only do something if the next row has a different value in the second column
'merge rows in the first and second columns
.Worksheet.Range(.Cells(startRow, 1), .Cells(endRow, 1)).MergeCells = True
.Worksheet.Range(.Cells(startRow, 2), .Cells(endRow, 2)).MergeCells = True
'Check for "no_fix" or blank
isQM = True ' Assume it is a "QM" until we determine it isn't
For r = startRow To endRow
If .Cells(r, 4).Value <> "" And .Cells(r, 4).Value <> "no_fix" Then
'If the 4th column is not blank and is not "no_fix", it isn't a "QM"
isQM = False
Exit For
End If
Next
'Update column 1 to show QM or QA
With .Cells(startRow, 1)
If isQM Then
.Value = "QM"
.Interior.Color = vbGreen
Else
.Value = "QA"
.Interior.Color = vbRed
End If
End With
'Point to start of next block
startRow = endRow + 1
End If
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Writing an 2D array to a range of cells

I've got an array of a range of cells and I need to write it back to a specific range of cells. My first 2 columns are working as desired when writing back to the new range of cells but the next 2 columns are mirroring column 2 for columns 3 and 4.
Array Range:
1,2,3,4
2,2,3,5
3,4,5,6
will write as:
1,2,2,2
2,2,2,2
3,4,4,4
What I want is:
1,2,3,4
2,2,3,5
3,4,5,6
Dim myRange As Range
Dim scriptDic As Variant
Dim arr As Variant
Dim i As Integer
Dim x As Integer
With ThisWorkbook.Sheets("AGGREGATE")
Set myRange = .Range("H4:K19")
Set scriptDic = CreateObject("Scripting.Dictionary")
arr = myRange.Value
For i = 1 To UBound(arr, 1)
If arr(i, 1) <> "" Then
scriptDic(arr(i, 1)) = scriptDic(arr(i, 1)) + arr(i, 2)
End If
Next
Application.ScreenUpdating = False
.Range("M4:P19").ClearContents
myRange.Range("F1").Resize(scriptDic.Count, 1) = Application.WorksheetFunction.Transpose(scriptDic.keys)
myRange.Range("G1").Resize(scriptDic.Count, 1) = Application.WorksheetFunction.Transpose(scriptDic.items)
myRange.Range("H1").Resize(scriptDic.Count, 1) = Application.WorksheetFunction.Transpose(scriptDic.items)
myRange.Range("I1").Resize(scriptDic.Count, 1) = Application.WorksheetFunction.Transpose(scriptDic.items)
Application.ScreenUpdating = True
End With
I am assuming that it has to do with this section but I'm not very good with dimensional arrays.
For i = 1 To UBound(arr, 1)
If arr(i, 1) <> "" Then
scriptDic(arr(i, 1)) = scriptDic(arr(i, 1)) + arr(i, 2)
End If
Any help would be much appreciated!
For this purpose, I would get rid of the Dictionary, and just use RemoveDuplicates to obtain the unique key values. Then I would use SUMIF to get the desired answers:
Sub test()
Dim numRows As Long
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("AGGREGATE")
'Clear existing contents of column M:P
.Range("M4", .Cells(.Rows.Count, "M").End(xlUp).Offset(0, 3)).ClearContents
'Copy keys to column M
numRows = .Cells(.Rows.Count, "H").End(xlUp).Row - 3
.Range("M4").Resize(numRows, 1).Value = .Range("H4").Resize(numRows, 1).Value
'Generate unique list
.Range("M4").Resize(numRows, 1).RemoveDuplicates Columns:=1, Header:=xlNo
'Calculate answers in column N to P
numRows = .Cells(.Rows.Count, "M").End(xlUp).Row - 3
.Range("N4").Resize(numRows, 3).Formula = "=SUMIF($H:$H,$M4,I:I)"
'Convert formulas to values
.Range("N4").Resize(numRows, 3).Value = .Range("N4").Resize(numRows, 3).Value
End With
Application.ScreenUpdating = True
End Sub

looping through an entire column of values and if value matches, cut and paste it to another sheet

I have columns A, B, C, D, and E with data.
My goal is to start in cell A1, loop through every single record in column A while looking for a particular value "Grey". If the text in cells is equal to "Grey" then i want to cut and paste then entire row to a newly created sheet, starting in A1. here's what my code looks like ....
Dim n As Long
Dim nLastRow As Long
Dim nFirstRow As Long
Dim lastRow As Integer
ActiveSheet.UsedRange
Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row
Worksheets("Original").Activate
With Application
.ScreenUpdating = False
Sheets.Add.Name = "NewSheet"
Sheets("Original").Select
Range("A1").Select
Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row
With ActiveSheet
For n = nLastRow To nFirstRow Step -1
If .Cells(n, "A") = "Grey" Then
.Cells(n, "A").EntireRow.Cut Sheets("NewSheet").Cells(i, "A")
.Cells(n, "A").EntireRow.Delete
n = n + 1
End If
Next
End With
.ScreenUpdating = True
End With
So this macro creates a new sheet - however when it gets to a cell where the value is grey it gives me an error on this line....
.Cells(n, "A").EntireRow.Cut Sheets("NewSheet").Cells(i, "A")
Error says:
Application defined or object defined error.
Anyone have any idea why?
You need to declare i, and set it. As mentioned, the first time it occurs it's looking to paste in row 0, which doesn't exist.
Also, it's best to avoid using .Select/.Activate, and work directly with the data.
How does this work?
Sub t()
Dim r As Range
Dim n As Long, i As Long, nLastRow As Long, nFirstRow As Long
Dim lastRow As Integer
Dim origWS As Worksheet, newWS As Worksheet
Set origWS = Worksheets("Original")
Set newWS = Sheets.Add
newWS.Name = "NewSheet"
Set r = origWS.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row
i = 1
With Application
.ScreenUpdating = False
With origWS
For n = nLastRow To nFirstRow Step -1
If .Cells(n, "A") = "Grey" Then
.Cells(n, "A").EntireRow.Copy newWS.Cells(i, "A")
.Cells(n, "A").EntireRow.Delete
i = i + 1
End If
Next
End With
.ScreenUpdating = True
End With
End Sub
You also don't need to do n = n + 1 (unless I missed something).
Edit: Changed .Cut to .Copy, per OP's wish to keep formatting.
Or you may try something like this...
Sub CopyToNewSheet()
Dim sws As Worksheet, dws As Worksheet
Application.ScreenUpdating = False
Set sws = Sheets("Original")
On Error Resume Next
Set dws = Sheets("NewSheet")
dws.Cells.Clear
On Error GoTo 0
If dws Is Nothing Then
Sheets.Add(after:=sws).Name = "NewSheet"
Set dws = ActiveSheet
End If
sws.Rows(1).Insert
On Error Resume Next
With sws.Range("A1").CurrentRegion
.AutoFilter field:=1, Criteria1:="Grey"
.SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
dws.Rows(1).Delete
Application.ScreenUpdating = True
End Sub

Consolidate several rows into a single row vba

I need to create a sub to consolidate some data. I have several rows (anywhere from 4k to 20k) that I need to consolidate and sum the values from each column (from C to N).
The input data looks like this:
input
For the output, it should sum the columns for each SKU (Column A) and delete the rest.
Like this:
output
It should be simple enough, but I can’t seem to come up with an appropriate solution. I tried using an array with a scripting dictionary but I can’t figure out how to store more than a single value for each key. Sample (unfinished) code:
Dim sArray As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
sArray = Range(currentRange).Value
For i = 1 To UBound(sArray, 1)
For j = 3 To UBound(sArray, 2)
If dict.exists(sArray(i, 1)) = False Then
dict.Add sArray(i, 1), sArray(i, j)
Else
'this part is very wrong:
dict(sArray(i, 1)) = dict(sArray(i, j)) + sArray(i, j)
End If
Next
Next
Thank you very much in advance!
Try this, It sums the values in Column Q:AB then paste them back and removes the duplicates.
Sub dupremove()
Dim ws As Worksheet
Dim lastrow As Long
Set ws = Sheets("Sheet12") ' Change to your sheet
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C2:N" & lastrow)
.Offset(, 14).FormulaR1C1 = "=SUMIF(C1,RC1,C[-14])"
.Value = .Offset(, 14).Value
.Offset(, 14).ClearContents
End With
With .Range("A1:N" & lastrow)
.Value = .Value
.RemoveDuplicates 1, xlYes
End With
End With
Before:
After:
I came up with the following solution instead and it took 30 seconds to run it (not entirely my own idea, borrowed some code from someplace else):
Sub dupes()
Dim MyRange As Range
Dim RowNum As Long
RowNum = 1
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set MyRange = Range("A2:N14200") 'for test only, on the real sub it's dynamic
MyRange.Sort key1:=Range("A2"), order1:=xlAscending
For Each Row In MyRange
With Cells
While Cells(RowNum, 1) = Cells(RowNum + 1, 1) And Cells(RowNum + 1, 1) <> "" 'very important the second condition or it will continue to loop forever
For i = 3 To 14
Cells(RowNum, i) = Cells(RowNum, i) + Cells(RowNum + 1, i)
Next
Rows(RowNum + 1).EntireRow.Delete
Wend
End With
RowNum = RowNum + 1
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
It's kinda messy but it does the trick. Thanks to everyone!

Optimizing excel arrays

I have a very large data set (600,000 rows) of data structured in the following format:
1) There are around 60 products. One is a Total US number, while the others are for Manufacturers and are labled as KMFs. There are also some labeled as PCKGs(but aren't relevant for this question)
2) Each product is located in 60 different markets
3) Each market has 20 different locations
4) I have 12 metrics for which I need to calculate data in the following manner: Total US number - sum(KMFs) for each metric
I have written vba code for this but it is taking too long to run(around 20 minutes) I need to run similar code on at least 20 worksheets. I have tried various methods such as setting screenUpdating etc. to false. Here is my code. I am new to vba coding so I may have missed obvious things. Please let me know anything is unclear. Please help!
Sub beforeRunningCode()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
End Sub
Sub returnToOriginal()
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState
End Sub
Function LastRowFunc(Sheet) As Long
LastRowFunc = ActiveWorkbook.Worksheets(Sheet).Range("A2", Worksheets(Sheet).Range("A2").End(xlDown)).Rows.Count
End Function
Function LastColFunc(Sheet) As Long
With ActiveSheet
LastColFunc = ActiveWorkbook.Sheets(Sheet).Cells(1, .Columns.Count).End(xlToLeft).Column
End With
End Function
Sub AOCalculate()
Call beforeRunningCode 'Optimize Excel
Dim LastRow As Long
Dim LastCol As Long
Dim Period As String
Dim Sheet As String
Dim Arr(1 To 16)
Dim Count As Integer
Sheet = "Energy_LS_Bottler"
Period = "2016 WAVE 1 - 3 W/E 05/07"
LastRow = LastRowFunc(Sheet) 'Calculate last row for which data exists
LastCol = LastColFunc(Sheet) 'Calculate last column for which data exists
For Each Location In ActiveWorkbook.Sheets("Locations").Range("D7:D28").Value
For Each Market In ActiveWorkbook.Sheets("Markets").Range("A5:A92").Value
Count = Count + 1
Arr(1) = Market
Arr(2) = "AO"
Arr(3) = Location
Arr(4) = Period
With ActiveWorkbook.Sheets(Sheet) 'Filtering for KMF
.AutoFilterMode = False
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=17, Criteria1:="=KMF"
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=1, Criteria1:=Market
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=3, Criteria1:=Location
End With
For k = 5 To 16
Arr(k) = Application.WorksheetFunction.Sum(ActiveWorkbook.Sheets(Sheet).Range(Cells(1, k), Cells(LastRow, k)).SpecialCells(xlCellTypeVisible))
Next k
With ActiveWorkbook.Sheets(Sheet) ' filtering for Total US
.AutoFilterMode = False
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=17, Criteria1:="=Total US"
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=1, Criteria1:=Market
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=3, Criteria1:=Location
End With
For k = 5 To 16
Arr(k) = -Arr(k) + Application.WorksheetFunction.Sum(ActiveWorkbook.Sheets(Sheet).Range(Cells(1, k), Cells(LastRow, k)).SpecialCells(xlCellTypeVisible))
Next k
For j = 1 To 16
ActiveWorkbook.Sheets(Sheet).Cells(LastRow + Count, j).Value = Arr(j)
Next j
Erase Arr
Next
Next
ActiveWorkbook.Sheets(Sheet).AutoFilterMode = False
Call returnToOriginal
End Sub
[Edit]: Here is a link to a sample data set https://drive.google.com/file/d/0B3MkGa57h6g_WGl2WWlWekd4NU0/view?usp=sharing
I think that this will work (though I haven't had a chance to test it), and should be a lot faster:
Sub AOCalculate()
Call beforeRunningCode 'Optimize Excel
Dim LastRow As Long
Dim LastCol As Long
Dim Period As String
Dim Sheet As String
Dim Arr() '1 To 2000, 1 To 16)
Dim Count As Integer
Sheet = "Energy_LS_Bottler"
Period = "2016 WAVE 1 - 3 W/E 05/07"
LastRow = LastRowFunc(Sheet) 'Calculate last row for which data exists
LastCol = LastColFunc(Sheet) 'Calculate last column for which data exists
'copy all of the relevant cells to local arrays for speed
Dim Locations(), Markets(), data()
Markets = ActiveWorkbook.Sheets("Markets").Range("A5:A92").Value
Locations = ActiveWorkbook.Sheets("Locations").Range("D7:D28").Value
'(pretty sure the following line needs to localize the Cells() to .Cells())
data = ActiveWorkbook.Sheets(Sheet).Range(Cells(1, 1), Cells(LastRow, LastCol)).Value '**'
ReDim Arr(1 To UBound(Markets, 1) * UBound(Locations, 1), 16)
'make an index of pointers into our accumulation array
Dim counts As New Collection
Dim i As Long, l As Long, m As Long
For l = 1 To UBound(Locations, 1)
Location = Locations(l, 1) '**'
For m = 1 To UBound(Markets, 1)
Market = Markets(m, 1) '**'
i = i + 1
counts.Add i, CStr(Location) & "~" & CStr(Market)
'counts.Add NewAccumArray(Location, Market, Period), CStr(Location) & "~" & CStr(Market)
Arr(i, 1) = Market
Arr(i, 2) = "AO"
Arr(i, 3) = Location
Arr(i, 4) = Period
Next
Next
' go through each row and add it to the appropiate count in the array
Dim r As Long
Dim key As String, idx As Long
For r = 1 To UBound(data, 1)
key = CStr(data(r, 3)) & "~" & CStr(data(r, 1))
If data(r, 17) = "KMF" Then
idx = counts(key)
For k = 5 To 16
Arr(idx, k) = Arr(idx, k) - data(r, k)
Next k
Else
If data(r, 17) = "Total US" Then
idx = counts(key)
For k = 5 To 16
Arr(idx, k) = Arr(idx, k) + data(r, k)
Next k
End If
End If
Next r
' output the results
ActiveWorkbook.Sheets(Sheet).Range(Cells(LastRow + 1, 1), Cells(LastRow + Count, 16)).Value = Arr
ActiveWorkbook.Sheets(Sheet).AutoFilterMode = False
Call returnToOriginal
End Sub
Answering the query "What did I mean by this?"
'(pretty sure the following line needs to localize the Cells() to .Cells())
data = ActiveWorkbook.Sheets(Sheet).Range(Cells(1, 1), Cells(LastRow, LastCol)).Value '**'
The use of Cells(..) here is fundamentally unreliable and broken. this is because Cells(..) is really a shortcut for ActiveSheet.Cells(..) and the Active* properties are inherently slow and unreliable because they can change while the code is running. Worse, this code is assuming that ActiveSheet = Energy_LS_Blotter which is far from certain.
The correct way to write this line would be like this:
data = ActiveWorkbook.Sheets(Sheet).Range( _
ActiveWorkbook.Sheets(Sheet).Cells(1, 1), _
ActiveWorkbook.Sheets(Sheet).Cells(LastRow, LastCol) _
).Value
But that is long, ugly and inconvenient. An easier way would be to use either a Sheet variable, or a With:
With ActiveWorkbook.Sheets(Sheet)
data = .Range(.Cells(1, 1), .Cells(LastRow, LastCol)).Value
End With