I have 280,000 rows with 36 columns. I'm looking to pair down the file. I would like to reduce the file so that there are no more than 10 rows per company (column H). Some companies have 3 rows, some have 5000. I would like the macro to return a sheet with up to, but no more than 10 rows per company along with all of columns associated with their row.
There are 5 sheets on my file. The sheet I'm trying to reduce is titled "All comp", the blank sheet where I want to the results to go titled "new data".
I am trying to use the below macro, but I'm getting the error: Run-time error '1004': Cannot run Visual Basic macro because of a syntax error
It highlights .calculate as the first step in what is wrong with what I've entered.
There are 5 sheets on my file. The sheet I'm trying to reduce is titled "All comp", the blank sheet where I want to the results to go titled "new data".
I am trying to use the below macro, but I'm getting the error: Run-time error '1004': Cannot run Visual Basic macro because of a syntax error
It highlights .calculate as the first step in what is wrong with what I've entered.
Code:
Sub TenDuplicates()
With Application
.ScreenUpdating = False
.Calculate
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
End With
Dim raw As Worksheet
Dim output As Worksheet
Dim names() As String
Dim nextRow As Long
Dim counter As Integer
nextRow = 1
counter = 0
Set raw = Sheets("zebraUS")
Set output = Sheets("New data")
With output
.UsedRange.Clear
.Cells(1, 1).EntireColumn.Value = raw.Cells(1, 8).EntireColumn.Value
.Range("H:H").RemoveDuplicates Columns:=1, Header:=xlNo
For x = 1 To .Cells(Rows.Count, "H").End(xlUp).Row
If x = 1 Then
ReDim Preserve names(1 To 1)
Else
ReDim Preserve names(1 To x)
End If
names(x) = .Cells(x, 1)
Next x
.UsedRange.Clear
End With
With raw
For x = 1 To UBound(names)
counter = 0
For y = 1 To .Cells(Rows.Count, "8").End(xlUp).Row
If .Cells(y, 8) = names(x) Then
output.Cells(nextRow, 1).EntireRow.Value = _
.Cells(y, 1).EntireRow.Value
counter = counter + 1
nextRow = nextRow + 1
End If
Select Case counter
Case 10
GoTo nextName
Case Else
End Select
Next y
nextName:
Next x
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
Last edited by a moderator: