# Another date frequency problem

#### pinholsm

##### Board Regular
I am trying to condense a sheet that has duplicate information in it due to date break ranges and frequencies

The frequencies are Monday 1 tuesday 2 etc Sunday 7. column header and row information below
Out FL Freq Eff Until
Dep Out FL Freq Eff Until
10:15 EV4085 1234567 9-Jul-07 31-Jul-07
10:15 EV4085 34 1-AUG-07 20 Aug- 07
10:15 EV4085 12 67 4-Aug-07 18-aug-07

In the above example I would like to be able to get rid of rows 3 and 4 and have row 2 10:15 EV4085 1234567 9-Jul-07 20-Aug-07

Any good way to make that happen?

### Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
Assuming that :
- columns A:E contain your data
- the first row for each flight will always have all frequencies for that filght in column C AND will have the earliest Eff Date in column D

Then :-

Code:
``````Sub Test()
Application.ScreenUpdating = False
With Range([F2], [A65536].End(xlUp)(1, 6))
.EntireRow.Sort Key1:=[B2], Order1:=xlAscending, _
.FormulaR1C1 = "=IF(RC[-4]<>R[-1]C[-4],RC[-2],"""")"
.SpecialCells(xlCellTypeFormulas, 2).FormulaR1C1 = "=R[-1]C"
.Offset(, -2) = .Value
.EntireRow.Sort Key1:=[B2], Order1:=xlAscending, _
Key2:=[D2], Order2:=xlAscending, _
Key3:=[E2], Order2:=xlDescending, _
.FormulaR1C1 = "=IF(RC[-4]<>R[-1]C[-4],RC[-1],"""")"
.SpecialCells(xlCellTypeFormulas, 2).FormulaR1C1 = "=R[-1]C"
.Offset(, -1) = .Value
.FormulaR1C1 = "=IF(RC[-4]<>R[-1]C[-4],1,"""")"
.SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete
.EntireColumn.Delete
End With
Application.ScreenUpdating = True
End Sub``````

Ok that is a great start, but it is deleting too much information

For example:
Dep Out FL Freq Eff Until Des1
9:44 EV4087 12345 1-Aug-07 20-Aug-07 YUL
9:44 EV4087 67 1-Aug-07 20-Aug-07 YUL

becomes:
Dep Out FL Freq Eff Until Des1
9:44 EV4087 12345 1-Aug-07 20-Aug-07 YUL

Iam looking for the freq column to convert that to 1234567 and only have 1 entry for that record

Code:
``````Sub Test()
Dim rng As Range, cell As Range
Application.ScreenUpdating = False
With Range([G2], [A65536].End(xlUp)(1, 7))
.EntireRow.Sort Key1:=[B2], Order1:=xlAscending, _
.FormulaR1C1 = "=IF(RC[-5]<>R[-1]C[-5],RC[-3],"""")"
.SpecialCells(xlCellTypeFormulas, 2).FormulaR1C1 = "=R[-1]C"
.Offset(, -3) = .Value
.EntireRow.Sort Key1:=[B2], Order1:=xlAscending, _
Key2:=[D2], Order2:=xlAscending, _
Key3:=[E2], Order2:=xlDescending, _
.FormulaR1C1 = "=IF(RC[-5]<>R[-1]C[-5],RC[-2],"""")"
.SpecialCells(xlCellTypeFormulas, 2).FormulaR1C1 = "=R[-1]C"
.Offset(, -2) = .Value
.FormulaR1C1 = "=IF(RC[-5]<>R[-1]C[-5],1,"""")"
With .Offset(, 1)
.FormulaR1C1 = "=IF(R[1]C[-1]=1,RC[-5],RC[-5] &R[1]C)"
.Value = .Value
End With
.SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete
End With
Set rng = Range([H2], [H65536].End(xlUp))
For Each cell In rng
cell = UniqueNbrs(cell.Value)
cell = SortNbrs(cell.Value)
Next
With Range([C2], [C65536].End(xlUp))
.Value = .Offset(, 5).Value
End With
[G:H].Delete
Application.ScreenUpdating = True
End Sub

Private Function SortNbrs(origString As String) As String
Dim currentChar As String
Dim sourceNum As Integer
Dim destNum As Integer
For sourceNum = 1 To Len(origString)
currentChar = Mid(origString, sourceNum, 1)
If sourceNum = 1 Then
SortNbrs = currentChar
Else
destNum = 1
While destNum < Len(origString) And currentChar > Mid(SortNbrs, destNum, 1)
destNum = destNum + 1
Wend
SortNbrs = Left(SortNbrs, destNum - 1) & currentChar & Mid(SortNbrs, destNum)
End If
Next sourceNum
End Function

Public Function UniqueNbrs(ByVal origString As String) As String
Dim oCol As New Collection
Dim sAns As String
Dim lCtr As Long, lCount As Long
Dim sChar As String
lCount = Len(origString)
For lCtr = 1 To lCount
sChar = Mid(origString, lCtr, 1)
On Error Resume Next
If Err.Number = 0 Then sAns = sAns & sChar
Err.Clear
Next
UniqueNbrs = sAns
End Function``````

Still not working

Either I am not doing something right??? But I am getting an error.

See my info below

AC Dep Dest 1 Gate Zone Out FL Freq Eff Until
777 21:05 DXB E11 21 8 4 23-Aug-07 30-Aug-07
777 21:05 DXB E11 21 8 2 21-Aug-07 21-Aug-07
777 21:05 DXB E11 21 8 3 22-Aug-07 29-Aug-07
777 21:05 DXB E26 24 8 6 25-Aug-07 25-Aug-07
777 21:05 DXB E26 24 8 7 26-Aug-07 26-Aug-07
777 21:05 DXB E11 21 8 2 28-Aug-07 28-Aug-07

I need this consolidated down to 1 line that let's me know the frequency

Can you help? We are so close

What error are you getting and on what line of code?

The worksheet headings in your most recent post are completely different from the headings in your previous posts !!

Please post a copy of your worksheet before running the macro and a copy showing the desired results after running it.

Replies
16
Views
2K
Replies
5
Views
341
Replies
4
Views
662
Replies
12
Views
641
Replies
5
Views
259

1,217,317
Messages
6,135,847
Members
449,965
Latest member
Ckl43

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

### Which adblocker are you using?

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

### Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back