I have a spreadsheet with thousands of rows and in column B there are numerous duplicates and then in column G there is that row's respective value. I need to remove the duplicates from column B, but leave in the row that has the highest value (i.e max column G). Is there a way to automate this via VBA as it'll need to be done on numerous occasions?
Thanks
You can try this:
Sub test()
Dim i As Long, j As Long
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Change the name of your sheet
With ws
i = 1 ' Start at Row 1
Do While Not IsEmpty(.Cells(i, 2))
j = 1 ' Start at Row 1
Do While Not IsEmpty(.Cells(j, 2))
If i <> j Then
If .Cells(i, 2).Value = Cells(j, 2).Value Then
If .Cells(i, 7).Value > Cells(j, 7) Then
Rows(j).EntireRow.Delete
j = j - 1
Else
Rows(i).EntireRow.Delete
If i > 1 Then i = i - 1
j = 1
End If
End If
End If
j = j + 1
Loop
i = i + 1
Loop
End With
End Sub
Related
I have a table with information in column A and an appropriate value in column B. I want to write a macro that inserts a new row for each "Person" in dependence of the value in column B and copies the original information into that row, which for example means that in the end there are 5 rows with "Person A", 2 rows for "Person B" etc.
original table:
result:
My first approach looks like that. It doesn't work.
Dim i, j, k As Integer
For i = Range("A" & Range("A:A").Rows.Count).End(xlUp).Row To 1 Step -1
For j = 1 To Range("B" & i)
Rows(i).Select
Selection.Insert Shift:=xlDown
k = k + j
Range(Cells(k, 1), Cells(k, 2)).Copy Destination:=Range("A" & i)
Next j
Next i
This would work for you, changing the number of inserts based on value in column B:
Option Explicit
Sub test()
With Sheets(1)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = lastRow To 1 Step -1
If IsNumeric(.Cells(i, 2).Value) = True Then
Dim numberOfInserts As Long
numberOfInserts = .Cells(i, 2).Value - 1
If numberOfInserts > 0 Then
Dim insertCount As Long
For insertCount = 1 To numberOfInserts
.Rows(i).Copy
.Rows(i).Insert
Next insertCount
End If
End If
Next i
End With
End Sub
First we check that you're dealing with numbers. Second you have a single line already, so number -1, then that this number is >0. Lastly, you insert via a loop which does the counting for you.
Test data:
Output after running:
Your index calculation is messed up. Use the debugger, step thru the code (F8) and notice what happens:
a) Your Select/Insert-construct creates a new row above the row you want to copy, not below.
b) Your calculation of index k fails: You are not initializing k, so it starts with value 0. Than you add j (1..3) to k, resulting in values 1, 3, 6, and copy data from that line.
I would suggest you take a different approach: Copy the original data into an array and then loop over that array. This avoids multiple Select, Copy and Insert statements (that are slow) and allow to copy the data from top to bottom.
Sub copy()
Dim rowCount As Long
Dim data As Variant
With ActiveSheet ' Replace with the sheet you want to work with
' Copy the current table into array
rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
data = .Range(.Cells(1, 1), .Cells(rowCount, 2))
Dim oldRow As Long, newRow As Long
newRow = 1
' Loop over old data
For oldRow = 1 To rowCount
Dim repeatCount As Long
repeatCount = Val(data(oldRow, 2)) ' We want to have so many occurrences of the row
if repeatCount <= 0 Then repeatCount=1
Dim col As Long
' Create "repeatCount" rows of data (copy column by column)
For col = 1 To 2
.Cells(newRow, col).Resize(repeatCount, 1) = data(oldRow, col)
Next col
newRow = newRow + repeatCount
Next
End With
End Sub
ive been looking into adding a groupBy function on a couple of sheets however i want to reference 5 sheets. In total i have about 7 but two of the worksheets have the common values in different columns (the five sheets have common variables in column B however two have the same variables in column G) otherwise i would have used ActiveSheet.
I've attached Chris Neilsen's example
Chris Neilsen's Group By Function
Sub demo()
Dim r As Range
Dim v As Variant
Dim i As Long, j As Long
With ActiveSheet
On Error Resume Next
' expand all groups on sheet
.Outline.ShowLevels RowLevels:=8
' remove any existing groups
.Rows.Ungroup
On Error GoTo 0
Set r = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))
End With
With r
'identify common groups in column B
j = 1
v = .Cells(j, 1).Value
For i = 2 To .Rows.Count
If v <> .Cells(i, 1) Then
' Colum B changed, create group
v = .Cells(i, 1)
If i > j + 1 Then
.Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
End If
j = i
v = .Cells(j, 1).Value
End If
Next
' create last group
If i > j + 1 Then
.Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
End If
' collapse all groups
.Parent.Outline.ShowLevels RowLevels:=1
End With
End Sub
I have tried the below code to link the sheets in the above example however it is out of range
With Worksheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")).Select
This can be easily done by adding a parameter to the sub code from Chris Neilsen:
Sub demo(ByRef ws As Worksheet)
Dim r As Range
Dim v As Variant
Dim i As Long, j As Long
With ws
On Error Resume Next
' expand all groups on sheet
.Outline.ShowLevels RowLevels:=8
' remove any existing groups
.Rows.Ungroup
On Error GoTo 0
Set r = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))
End With
With r
'identify common groups in column B
j = 1
v = .Cells(j, 1).Value
For i = 2 To .Rows.Count
If v <> .Cells(i, 1) Then
' Colum B changed, create group
v = .Cells(i, 1)
If i > j + 1 Then
.Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
End If
j = i
v = .Cells(j, 1).Value
End If
Next
' create last group
If i > j + 1 Then
.Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
End If
' collapse all groups
.Parent.Outline.ShowLevels RowLevels:=1
End With
End Sub
Now call that routine with any worksheet, or in a loop:
Sub Test()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
demo ws
Next ws
End Sub
PS: I do suggest changing the name of demo to something more appropriate, such as GroupDataOnSheet.
At a high level I am trying to set a cell equal to a random cell within a range. The issue I am having is that in this range I want to pull a random Value from, the Value I am taking is the result of an 'if' expression that either sets the cell to a Value or "". So when I chose the random value I only want to choose cells that have an actual value, not the "".
Does anyone know how to get this expected behavior?
The code below shows what I have tried currently, each large block is commented to help with understanding. The block I need help with replaces the values in each column until the next cell is blank then moves to the next column.
upperBound = 1798
lowerBound = 2
Randomize
'This loop section populates the data area with a static value in cell 9,3 then 9,4 etc..
For j = 3 To 15
val = Cells(9, j).Value
For i = 1 To val
Cells(12 + i, j).Value = Cells(9, j)
Next i
Next j
'This loop section uses the cells already populated down each column and replaces that value with the random value from the other range
Dim x As Integer
' Set numrows = number of rows of data.
For j = 3 To 15
NumRows = Range(Cells(13, j), Cells(13, j).End(xlDown)).Rows.Count
' Select cell 13,j.
Cells(13, j).Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
ActiveCell.Value = Worksheets("2017 Role IDs").Cells(Int((upperBound - lowerBound + 1) * Rnd + lowerBound), 2).Value
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
Next j
This is the data before the second block runs. I want to replace the values that just match the number in the second row with the random number in the range:
This is what I would like to look like:
But currently it looks like this because the random selector is taking blank values:
Something like this should work for you:
Sub tgr()
Dim wb As Workbook
Dim wsNums As Worksheet
Dim wsDest As Worksheet
Dim aData As Variant
Dim vData As Variant
Dim aNums() As Double
Dim aResults() As Variant
Dim lNumCount As Long
Dim lMaxRows As Long
Dim lRowCount As Long
Dim ixNum As Long
Dim ixResult As Long
Dim ixCol As Long
Set wb = ActiveWorkbook
Set wsNums = wb.Worksheets("2017 Role IDs")
Set wsDest = wb.ActiveSheet
With wsNums.Range("B2", wsNums.Cells(wsNums.Rows.Count, "B").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
lNumCount = WorksheetFunction.Count(.Cells)
If lNumCount = 0 Then Exit Sub 'No numbers
ReDim aNums(1 To lNumCount)
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Value
Else
aData = .Value
End If
'Load populated numeric cells into the aNums array
For Each vData In aData
If Len(vData) > 0 And IsNumeric(vData) Then
ixNum = ixNum + 1
aNums(ixNum) = vData
End If
Next vData
End With
lMaxRows = Application.Max(wsDest.Range("C9:O9"))
If lMaxRows = 0 Then Exit Sub 'Row count not populated in row 9 for each column
ReDim aResults(1 To WorksheetFunction.Max(wsDest.Range("C9:O9")), 1 To 13)
'Populate each column accordingly and pull a random number from aNums
For ixCol = 1 To UBound(aResults, 2)
If IsNumeric(wsDest.Cells(9, ixCol + 2).Value) Then
For ixResult = 1 To CLng(wsDest.Cells(9, ixCol + 2).Value)
Randomize
aResults(ixResult, ixCol) = aNums(Int(Rnd() * lNumCount) + 1)
Next ixResult
End If
Next ixCol
wsDest.Range("C13").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub
So I have a double loop that for some reason always skips to my outer loop for some reason. The loop goes from:
For j = lastColumn To 6 Step (-1)
to:
Next i
every single time. However, in my data set there's a mixed variety of data which should be captured in my if statement and count the data.
Any ideas? Maybe I formatted the macro wrongly.
Sub CheckDates()
Dim count As Integer
Dim i As Integer
Dim j As Integer
Sheets(1).Select
lastrow = ActiveSheet.Cells(Rows.count, "B").End(xlUp).Row
'have to keep data in a table for this to actually work as it ctrls+left to the table, which will end where the very last text of any row is
lastColumn = ActiveSheet.Cells(1, Columns.count).End(xlToLeft).Column
count = 0
i = 3
j = lastColumn
For i = 3 To lastrow
For j = lastColumn To 6 Step (-1)
If Sheet1.Cells(i, j) < Sheet2.Cells(1, 1) And Sheet1.Cells(i, j - 1) = "Reçu" Then
count = count + 1
GoTo NextIteration
End If
Next j
NextIteration:
Next i
Sheet2.Cells(1, 7) = count
Sheets(2).Select
'Runs the DeleteSAC Macro
Call DeleteSAC
End Sub
I don't quite follow what you're doing, but try this instead. Notice the Exit For. This should produce the result you're looking for, without the For-Next counter variables getting confused.
For i = 3 To lastrow
For j = lastColumn To 6 Step (-1)
If Sheet1.Cells(i, j) < Sheet2.Cells(1, 1) And Sheet1.Cells(i, j - 1) = "Reçu" Then
count = count + 1
Exit For
End If
Next j
Next i
Simplification
Use Long for rows, and Integer for columns.
When you write With Sheet1, everywhere where you should write Sheet1, e.g. Sheet1.Range(whatever)... you can write just .Range(whatever) instead, until you close with End With.
The Exit For exits only the For Loop where it is in. So it does exactly what you are doing with your Goto line, but you are using a line more.
When you use Sheet1 or Sheet2 etc. you are actually using code names so you can change the names in the tab and the code will still run.
Counting backwards is usually used when you delete row by row so there is no need to do so since you are only counting.
Option Explicit
Sub CheckDates()
Dim dataCount As Long
Dim i As Long
Dim j As Integer
Dim lastrow As Long
With Sheet1
lastrow = .Cells(.Rows.count, "B").End(xlUp).Row
'have to keep data in a table for this to actually work as it ctrls+left
'to the table, which will end where the very last text of any row is
lastColumn = .Cells(1, .Columns.count).End(xlToLeft).Column
For i = 3 To lastrow
For j = 6 To lastColumn
If .Cells(i, j) < Sheet2.Cells(1, 1) And .Cells(i, j - 1) = "Reçu" Then
dataCount = dataCount + 1
Exit For
End If
Next
Next
End With
With Sheet2
.Cells(1, 7) = dataCount
.Select
End With
'Runs the DeleteSAC Macro
DeleteSAC
End Sub
I am trying to calculate some values from specific columns in Sheet1 and Sheet2. The problem is that the Sub below first correctly calculates the numbers from a matrix in Sheet1. It puts the matrix in some cells on Sheet1. And then the code rewrites that matrix with the numbers from Sheet2. But I want to put the calculations from Sheet2 on Sheet2, not Sheet1. Any ideas about what I am doing wrong? Best Regards!
Sub Try()
Dim LastRow As Long
Dim LastOne As Long
Dim Sheetz As Variant
Sheetz = Array("Sheet1", "Sheet2")
For h = LBound(Sheetz) To UBound(Sheetz)
With Worksheets(Sheetz(h))
numbers = Array(1, 2, 3)
For j = LBound(numbers) To UBound(numbers)
For i = 1 To 3
LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
LastValue = .Cells(.Rows.Count, i).End(xlUp).Value
FirstOne = .Cells(LastRow - j, i).Value
Cells(i + 1, j + 5) = LastValue / FirstOne - 1
Next i
Next j
End With
Next h
End Sub