I want to remove duplicates based on the text in Column I and sum the values in Column C, the data in the other columns doesn't matter.
I do not want a pivot table and I am aware they are the preferred option for this type of thing.
An example of what I'd like to achieve:
I found VBA code and tried to modify it. It doesn't delete all the lines.
Sub Sum_and_Dedupe()
With Worksheets("data")
'deal with the block of data radiating out from A1
With .Cells(1, 1).CurrentRegion
'step off the header and make one column wider
With .Resize(.Rows.Count - 1, .Columns.Count + 1).Offset(1, 0)
.Columns(.Columns.Count).Formula = "=sumifs(c:c, i:i, i2)"
.Columns(3) = .Columns(.Columns.Count).Value
.Columns(.Columns.Count).Delete
End With
'remove duplicates
.RemoveDuplicates Columns:=Array(9), Header:=xlYes
End With
.UsedRange
End With
End Sub
This should be an answer to your question.
However, code might require adaptation if the range in which you look becomes very long.
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long, LastCol As Long, a As Double, i As Long
Dim Rng As Range
Dim Cell As Variant, Estimate As Variant
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
LastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set Rng = ws.Range(ws.Cells(2, 9), ws.Cells(LastRow, 9))
For Each Cell In Rng
i = 0
a = 0
For Each Estimate In Rng
If Estimate.Value = Cell.Value Then
i = i + 1 'Count nr of intances
a = a + ws.Cells(Estimate.Row, 3).Value 'sum booking value
If i > 1 Then
ws.Rows(Estimate.Row).Delete
i = 1
LastRow = LastRow - 1
End If
End If
Next Estimate
ws.Cells(Cell.Row, 3).Value = a 'Enter sum in booked this week
Next Cell
End Sub
You'll either need to change your current sheet name to data, or change the first two lines of this code to fit your needs. sh = the data sheet that you showed us. osh = an output sheet that this code will generate. Note also if column C or I move you can update the positions easily by changing colBooked and colEstimate. If you have more than a thousand unique estimate entries then make the array number larger than 999.
Sub summariseEstimates()
Dim sh As String: sh = "data"
Dim osh As String: osh = "summary"
Dim colBooked As Integer: colBooked = 3
Dim colEstimate As Integer: colEstimate = 9
Dim myArray(999) As String
Dim shCheck As Worksheet
Dim output As Worksheet
Dim lastRow As Long
Dim a As Integer: a = 0
Dim b As Integer
Dim r As Long 'row anchor
Dim i As Integer 'sheets
'Build summary array:
With Worksheets(sh)
lastRow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For r = 2 To lastRow
If r = 2 Then 'first entry
myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
Else
For b = 0 To a
If VBA.LCase(VBA.Replace(.Cells(r, colEstimate), " ", "")) = VBA.LCase(VBA.Replace(VBA.Split(myArray(b), ",")(0), " ", "")) Then 'match
myArray(b) = VBA.Split(myArray(b), ",")(0) & "," & VBA.Split(myArray(b), ",")(1) + .Cells(r, colBooked)
Exit For
End If
Next b
If b = a + 1 Then 'completed loop = no match, create new array item:
a = a + 1
myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
End If
End If
Next r
End With
'Create summary sheet:
On Error Resume Next
Set shCheck = Worksheets(osh)
If Err.Number <> 0 Then
On Error GoTo 0
Set output = Worksheets.Add(After:=Worksheets(sh))
output.Name = osh
Err.Clear
Else
On Error GoTo 0
If MsgBox("*" & osh & "* sheet already exists. Proceed to delete and recreate?", vbOKCancel, "Summary") = vbCancel Then
Exit Sub
Else
Application.DisplayAlerts = False
Worksheets(osh).Delete
Set output = Worksheets.Add(After:=Worksheets(sh))
output.Name = osh
End If
End If
'Output to summary sheet:
With Worksheets(osh)
.Cells(1, 1).Value = "ESTIMATE"
.Cells(1, 2).Value = "BOOKED THIS WEEK"
For b = 0 To a
.Cells(b + 2, 1).Value = VBA.Split(myArray(b), ",")(0)
.Cells(b + 2, 2).Value = VBA.Split(myArray(b), ",")(1)
Next b
.Columns("A:B").AutoFit
End With
End Sub
Related
I wrote a little code to mark the differences in two different tables.
When I run the code, there are many right "hits", but for some reason, sometimes the exact same value is marked as different. This mostly happened with numbers or if the alignment is not the same.
To get rid of the alignment- and formatting- problem I wrote/found the following Code:
Sub makeBeautiful()
Dim n As Integer
Dim m As Integer
Dim wks As Worksheet
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("bank-accountsNew")
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Worksheets("bank-accountsOld")
n = sht.UsedRange.Rows.Count
m = sht.UsedRange.Columns.Count
For j = 1 To m
For i = 1 To n
If sht.Cells(i, j).Value = "null" Then
sht.Cells(i, j).Value = " "
End If
Next i
Next j
For Each wks In Worksheets
wks.Cells.VerticalAlignment = xlTop
wks.Cells.HorizontalAlignment = xlLeft
Next wks
sht.Cells.NumberFormat = "General"
sht2.Cells.NumberFormat = "General"
End Sub
As far as I can tell, this works just fine.
To mark the differences, I have the following Code:
Sub changeFinder()
Dim n As Integer
Dim m As Integer
Dim p As Integer
Dim o As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim Result As String
Dim item1 As String
Dim item2 As String
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("bank-accountsNew")
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Worksheets("bank-accountsOld")
n = sht.UsedRange.Rows.Count
m = sht.UsedRange.Columns.Count
k = sht2.UsedRange.Rows.Count
l = sht2.UsedRange.Rows.Count
For j = 1 To m
sht.Columns(j + 1).Insert
sht.Columns(j + 1).Insert
For i = 2 To n
sht.Cells(i, j + 1).Value = Application.VLookup(sht.Cells(i, 1), sht2.Columns(1).Resize(, j), j, False)
Next i
For i = 2 To n
item1 = sht.Cells(i, j).Text
item2 = sht.Cells(i, j + 1).Text
Result = StrComp(item1, item2)
sht.Cells(i, j + 2) = Result
Next i
For i = 2 To n
If sht.Cells(i, j + 2) = 1 Then
sht.Cells(i, j).Interior.Color = vbRed
End If
Next i
sht.Columns(j + 1).Delete
sht.Columns(j + 1).Delete
Next j
End Sub
My idea was to create two new column next to every column I want to compare. Fill these two new column with the fitting value and a number to check either these values are the same or not. If not, the original value should be marked in red.
I have in both table almost the same bank accounts numbers as column 3.
Some of them are marked as different and some them are not marked as different, but in only case they are not the same. So, my code does not work properly.
As far as I can tell, every value is equally aligned and equally formatted, so I donĀ“t know what could cause Excel to think that the same numbers are different. :/
Table B is created by a json.file. Table A ist created by PowerQuery with two tables, which I have from a json.file.
I hope someone can help me here a litle bit.
Sincerely,
Julian
Rather than repeated VLookups consider using a Dictionary Object.
Option Explicit
Sub changeFinder()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim lastrow As Long, r As Long, r2 As Long
Dim lastcol As Long, c As Long
With ThisWorkbook
Set sht1 = .Sheets("bank-accountsNew")
Set sht2 = .Sheets("bank-accountsOld")
End With
' build look up to sheet2
Dim dict As Object, id As String, n As Long
Set dict = CreateObject("Scripting.Dictionary")
With sht2
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
' scan down sheet
For r = 2 To lastrow
id = Trim(.Cells(r, 1))
If dict.exists(id) Then
MsgBox "Error - duplicate id " & id, vbCritical, sht2.Name & " row " & r
Exit Sub
ElseIf Len(id) > 0 Then
dict.Add id, r
End If
Next
End With
' compare with sheet 1
With sht1
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
With .UsedRange
lastcol = .Columns.Count
.Interior.Color = xlNone 'clear sheet
End With
' scan down sheet
For r = 2 To lastrow
id = Trim(.Cells(r, 1))
' check exists on sheet2
If Not dict.exists(id) Then
.Rows(r).Interior.Color = RGB(128, 255, 128)
n = n + 1
Else
r2 = dict(id) ' sheet 2 row
' scan across columns
For c = 2 To lastcol
If Trim(.Cells(r, c)) <> Trim(sht2.Cells(r2, c)) Then
.Cells(r, c).Interior.Color = RGB(255, 128, 0)
n = n + 1
'Debug.Print .Cells(r, c), sht2.Cells(r2, c)
End If
Next
End If
Next
End With
' result
If n > 0 Then
MsgBox n & " differences found", vbExclamation
Else
MsgBox "No differences found", vbInformation
End If
End Sub
I apologize for the vague title as I'm not really sure where the error is. I think I'm having some compability issues with copying the elements of an array and then manipulating that data.
This is the code I have so far:
Sub listNotCompletedTasks()
Dim cell As Range
Dim sourceRange As Range
Dim targetRange As Range
Dim notCompleted() As Variant
Dim i As Integer
Dim lastr As Integer
'define sourceRange
lastr = Range("A" & Rows.count).End(xlUp).Row
Set sourceRange = Range("A2:A" & lastr)
'notCompleted is an array with all the offset cells of the cells in sourceRange
'that don't contain a "Completed" string
i = 0
For Each cell In sourceRange.Cells
If cell.Offset(0, 2).Value <> "Completed" Then 'if the cell in column C does not contain "completed"...
ReDim Preserve notCompleted(0 To i)
notCompleted(i) = cell.Value 'add cell in column A to array
i = i + 1
End If
Next cell
'define targetRange
lastRow = Cells(Rows.count, "Z").End(xlUp).Row
Set targetRange = Range("Z1:Z" & lastRow)
'copy all elements from the array to the targetRange
For i = 0 To UBound(notCompleted)
targetRange.Offset(i, 0).Value = notCompleted(i)
Next i
End Sub
Expected output:
This works well. The problem begins with the second step:
Sub listNoDuplicatesAndNoOfInstances()
Dim sourceRangeZ As Range
Dim targetRangeB As Range
Set sourceRangeZ = Sheets("SourceData").Range("Z2")
Set targetRangeB = Sheets("TargetSheet").Range("B17")
'add all of the unique instances of a string in Z from the notCompleted() array
Do Until IsEmpty(sourceRangeZ)
If Application.WorksheetFunction.CountIf(Sheets("TargetSheet").Range("B:B"), sourceRangeZ.Value) = 0 Then
targetRangeB.Value = sourceRangeZ.Value
Set targetRangeB = targetRangeB.Offset(1, 0)
Else
End If
Set sourceRangeZ = sourceRangeZ.Offset(1, 0)
Loop
'count every instance of those strings and add the value to the respective cell to the right
Set targetRangeB = Sheets("TargetSheet").Range("C17")
Do Until IsEmpty(targetRangeB.Offset(0, -1))
targetRangeB.Formula = "=COUNTIF(SourceData!Z:Z,Z" & targetRangeB.Row & ")"
Set targetRangeB = targetRangeB.Offset(2, 0)
Loop
End Sub
The first loop (the one that adds every unique instance of the strings to column B) works. The second loop (the one that returns the number of instances of each string) does not work, only returning zeroes. The thing is, if I manually do the steps of the first subroutine (use a Pivot Table to filter out the rows I need, then copy the relevant row and paste it to column Z), and then call the second subroutine, then it actually works!
So I'm assuming the first subroutine is the culprit. A "cheap" workaround that worked for me was to copy the range in Z to another column (using sourceRange.Copy/targetRange.PasteSpecial xlPasteAll) and then call the second subroutine. What am I doing wrong, and is there a better way to solve this?
A 2D array you can copy to sheet without looping.
Sub listNotCompletedTasks()
Dim wsSource As Worksheet, arNotCompl()
Dim lastrow As Long, i As Long, n As Long
Set wsSource = ThisWorkbook.Sheets("SourceData")
With wsSource
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim arNotCompl(1 To lastrow, 1 To 1)
For i = 2 To lastrow
If .Cells(i, "C") <> "Completed" Then
n = n + 1
arNotCompl(n, 1) = .Cells(i, "A")
End If
Next
If n = 0 Then Exit Sub
'copy array to targetRange
lastrow = .Cells(.Rows.Count, "Z").End(xlUp).Row
.Cells(lastrow + 1, "Z").Resize(n) = arNotCompl
End With
End Sub
Add the formula in column C when you add the unique value to column B.
Sub listNoDuplicatesAndNoOfInstances()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lastrow As Long, i As Long, n As Long
Dim arNotCompl(), v
Set wsSource = ThisWorkbook.Sheets("SourceData")
With wsSource
lastrow = .Cells(.Rows.Count, "Z").End(xlUp).Row
arNotCompl = .Range("Z2:Z" & lastrow).Value2
End With
Set wsTarget = ThisWorkbook.Sheets("TargetSheet")
n = 17
With wsTarget
For i = 1 To UBound(arNotCompl)
v = arNotCompl(i, 1)
If Application.WorksheetFunction.CountIf(.Range("B:B"), v) = 0 Then
.Cells(n, "B") = v
.Cells(n, "C").Formula = "=COUNTIF(SourceData!Z:Z,B" & n & ")"
n = n + 1
End If
Next
End With
End Sub
What I'd like my sheet to do is when the user has updated the values in the cells D3:D8 on the sheet "Buffy Cast" they can press the button and these values will be copied into the tab "Actual FTE". The tab "Actual FTE" has a table with multiple dates and the ID of the person. The code should find the column based on the date in the "Buffy Cast" sheet, and then the row ID, copying the data across to this location.
I admit to resurrecting some dictionary code to find the rows, which actually worked, but I'm having issues getting it to find the column. Sheets and code below, huge thank yous.
Validation Sheet
Blank Actuals Sheet
What I'd like to happen on the actuals sheet
and finally my code
Option Explicit
Sub Update()
Dim wsValidate As Worksheet, wsActual As Worksheet
Dim lrValidate As Long, lrActual As Long
Dim i As Long, r As Long, rc As Variant
Dim n As Long, m As Long
Dim dict As Object, key As String
Set dict = CreateObject("Scripting.Dictionary")
Set wsValidate = Worksheets("BuffyCast")
Set wsActual = Worksheets("ActualFTE")
Dim sourceWS As Worksheet, targetWS As Worksheet
Dim lastCol As Long, lastRow As Long, srcRow As Range
Dim found1 As Range, j As Long, Cr1 As String
'Find column
With wsActual
lastCol = .Cells(2, Columns.Count).End(xlToLeft).Column
For j = 1 To lastCol
Cr1 = Worksheets("BuffyCast").Range("D2")
Set srcRow = .Range("A2", .Cells(2, lastCol))
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)
Next
End With
'Make dictionary
With wsActual
lrActual = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lrActual
key = Trim(.Cells(i, "A"))
If dict.exists(key) Then
MsgBox "Duplicate ID No '" & key & "'", vbCritical, "Row " & i
Exit Sub
ElseIf Len(key) > 0 Then
dict.Add key, i
End If
Next
End With
With wsValidate
lrValidate = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lrValidate
key = Trim(.Cells(i, "A"))
If dict.exists(key) Then
r = dict(key)
wsActual.Cells(r, found1) = .Cells(i, "D")
n = n + 1
Else
.Rows(i).Interior.Color = RGB(255, 255, 0)
m = m + 1
End If
Next
End With
MsgBox n & "Actual FTE Update" & vbLf & m & " rows not found", vbInformation
End Sub
You can use the WorksheetFunction.Match method to find a value in a row:
Dim Col As Long
On Error Resume Next
Col = Application.WorksheetFunction.Match(wsValidate.Range("D2").Value2, wsActual.Rows(2), 0)
On Error GoTo 0
If Col = 0 Then
MsgBox "Column was not found", vbCritical
Exit Sub
End If
' here col has the column number you are looking for
' and you can write to that column like
wsActual.Cells(RowNumber, Col).Value = 123
This will find the value of wsValidate.Range("D2") in the second row of wsActual.
I'd like some help if possible! Currently, it's causing the excel sheet to crash each time it runs, perhaps because the loop is not ending. Could anyone try helping me fix my code? All 4 sheets have under 5000 rows.
I currently have a workbook with 4 sheets(the number of sheets will change) and one more sheet called Results.
I have managed to look for the string: "Employee Code:-" in Column B, and get the value in Column Y and Column K and paste it in Results A and B respectively. (starting in the 5th row of the Results sheet). (Moving to the next find if Column S and Column K have the same value).
I then would need the values from 3 and 4 rows below the "Employee Code" running from D to AN and pasting it alongside the values from S and K
Then leaving a line after the results have been pasted and repeating for the rest of the find values.
Sub FindAndExecute()
Dim Sh As Worksheet
Dim Loc As Range
Dim i,j As Integer
i = 5
For Each Sh In ThisWorkbook.Worksheets
With Sh.UsedRange
Set Loc = .Cells.Find(What:="Employee Code:-")
If Not Loc Is Nothing Then
Do Until Loc Is Nothing
If Loc.Offset(0, 9).Value <> Loc.Offset(0, 23).Value Then
Sheets("Result2").Cells(i, 1).Value = Loc.Offset(0, 9).Value
Sheets("Result2").Cells(i, 2).Value = Loc.Offset(0, 23).Value
j = 3
Do
Sheets("Result2").Cells(i, j).Value = Loc.Offset(3, j - 1).Value
Sheets("Result2").Cells(i + 1, j).Value = Loc.Offset(4, j -
1).Value
j = j + 1
Loop Until j > 35
i = i + 3
Else
End If
Set Loc = .FindNext(Loc)
Loop
End If
End With
Set Loc = Nothing
Next
End Sub
With FindNext check the search hasn't started again from the beginning.
Sub FandAndExecute2()
Const TEXT = "Employee Code:-"
Const COL_CODE = 2 ' B
Const COL_Y = 25 ' Y
Const COL_K = 11 ' K
' copy from
Const COL_START = "D"
Const COL_END = "AM"
' copy to
Const TARGET = "Result2"
Const START_ROW = 5
Dim wb As Workbook, ws As Worksheet, wsResult As Worksheet
Dim rng As Range, rngSearch As Range, rngCopy As Range
Dim r As Long, iLastRow As Long, iTarget As Long
Dim sFirstFind As String, K, Y, n As Integer
Set wb = ThisWorkbook
Set wsResult = wb.Sheets(TARGET)
iTarget = START_ROW
' scan sheets
For Each ws In wb.Sheets
If ws.Name = TARGET Then GoTo skip
iLastRow = ws.Cells(Rows.Count, COL_CODE).End(xlUp).Row
Set rngSearch = ws.Cells(1, COL_CODE).Resize(iLastRow)
' search for text
With rngSearch
Set rng = .Find(TEXT, LookIn:=xlValues)
If Not rng Is Nothing Then
sFirstFind = rng.Address
Do
r = rng.Row
K = ws.Cells(r, COL_K)
Y = ws.Cells(r, COL_Y)
If K <> Y Then
' copy block
wsResult.Cells(iTarget, "A").Value = K
wsResult.Cells(iTarget, "B").Value = Y
Set rngCopy = ws.Range(COL_START & r + 3 & ":" & COL_END & r + 4)
rngCopy.Copy wsResult.Cells(iTarget, "C")
iTarget = iTarget + 3
n = n + 1
End If
Set rng = .FindNext(rng) ' find next
Loop While Not rng Is Nothing And rng.Address <> sFirstFind
End If
End With
skip:
Next
MsgBox n & " blocks copied to " & wsResult.Name, vbInformation
End Sub
The following code converts a table of values to a single column.
The problem is, with my table the number of rows in each column decreases by one for each successive column. Similar to the table shown below.
I am VERY new to writing code and only know the very basics. I copied a script found online to convert a range of values to a single column. The portion of code that I wrote to delete any blank cells is slowing the code tremendously. To convert around 250,000 points to a column is taking roughly 9 hours. I am hoping to reduce the processing time as this is a script I expect to use regularly.
Sub CombineColumns()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim rng As Range
Dim iCol As Long
Dim lastCell As Long
Dim K As Long
K = 484
'set K equal to the number of data points that created the range
Set rng = ActiveCell.CurrentRegion
lastCell = rng.Columns(1).Rows.count + 1
For iCol = 2 To rng.Columns.count
Range(Cells(1, iCol), Cells(rng.Columns(iCol).Rows.count, iCol)).Cut
ActiveSheet.Paste Destination:=Cells(lastCell, 1)
lastCell = lastCell + rng.Columns(iCol).Rows.count
Next iCol
Dim z As Long
Dim m As Long
z = K ^ 2
For Row = z To 1 Step -1
If Cells(Row, 1) = 0 Then
Range("A" & Row).Delete Shift:=xlUp
Application.StatusBar = "Progress: " & Row & " of z: " & Format((z - Row) / z, "Percent")
DoEvents
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sample Table Structure
Because I gave errant information on where this should be posted.
The following code will do what you want nearly instantly.
I used arrays to limit the number of interactions with the worksheet.
Sub foo5()
Dim ws As Worksheet
Dim rng() As Variant
Dim oarr() As Variant
Dim i&, j&, k&
Set ws = ThisWorkbook.Worksheets("Sheet19") 'Change to your sheet
With ws
rng = .Range("A1", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft))).Value
ReDim oarr(1 To Application.WorksheetFunction.CountA(rng), 1 To 1)
k = 1
For i = LBound(rng, 1) To UBound(rng, 1)
For j = LBound(rng, 2) To UBound(rng, 2)
If rng(i, j) <> "" Then
oarr(k, 1) = rng(i, j)
k = k + 1
End If
Next j
Next i
.Range("A1", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft))).Clear
.Range("A1").Resize(UBound(oarr), 1).Value = oarr
End With
End Sub