What is the perfect way (or smartest) to skip the continous recurring values?

[prabha_friend]

Please see the attached png for sample records.

Many Regions, Many Towers, Many Countries and all..
Has to create a worksheet for Each Region-Tower and Paste the countries' records.

Private Sub Input_Click()
Dim Mainrset As Recordset
Dim Temp As Variant
Set Mainrset = CurrentDb.OpenRecordset("Query_Form")
Mainrset.MoveLast
Mainrset.MoveFirst
ReDim Temp(0)
Set Temp(0) = CurrentDb.OpenRecordset("SELECT Region_Name FROM Regions;")
Temp(0).MoveLast
Temp(0).MoveFirst
ReDim Preserve Temp(1)
Set Temp(1) = CurrentDb.OpenRecordset("SELECT Tower_Name FROM Towers;")
Temp(1).MoveLast
Temp(1).MoveFirst
Excel.Application.Visible = True
Workbooks.Add
While Not Temp(0).EOF
While Not Temp(1).EOF
Sheets(1).Name = Temp(0)!Region_Name & "-" & Temp(1)!Tower_Name
Mainrset.Filter = "Region_Name = '" & Temp(0)!Region_Name & "' AND Tower_Name='" & Temp(1)!Tower_Name & "'"
ReDim Preserve Temp(2)
Set Temp(2) = Mainrset.OpenRecordset
Temp(2).MoveLast
Temp(2).MoveFirst
Range("A1").CopyFromRecordset (Temp(2))
Temp(1).MoveNext
Wend
Temp(0).MoveNext
Wend
End Sub

The above code is not correct as some Tower/Process are not associated with some countries. Usually What I do is to loop through all the records and look for the changes in the field. Is that the only way? (Actually I have met this scenario many times but as I had gap in my career, currently struggling to find the right way).

 

[vbaInet]

prabha I can't read your code. Can you please put it in Code tags.

 

[pr2-eugin]

Private Sub Input_Click()
    Dim Mainrset As Recordset
    Dim Temp As Variant
    
    Set Mainrset = CurrentDb.OpenRecordset("Query_Form")
    Mainrset.MoveLast
    Mainrset.MoveFirst
    
    ReDim Temp(0)
    
    Set Temp(0) = CurrentDb.OpenRecordset("SELECT Region_Name FROM Regions;")
    Temp(0).MoveLast
    Temp(0).MoveFirst
    
    ReDim Preserve Temp(1)
    
    Set Temp(1) = CurrentDb.OpenRecordset("SELECT Tower_Name FROM Towers;")
    Temp(1).MoveLast
    Temp(1).MoveFirst
    
    Excel.Application.Visible = True
    Workbooks.Add
    
    While Not Temp(0).EOF
        While Not Temp(1).EOF
            Sheets(1).Name = Temp(0)!Region_Name & "-" & Temp(1)!Tower_Name
            Mainrset.Filter = "Region_Name = '" & Temp(0)!Region_Name & "' AND Tower_Name='" & Temp(1)!Tower_Name & "'"
            ReDim Preserve Temp(2)
            Set Temp(2) = Mainrset.OpenRecordset
            Temp(2).MoveLast
            Temp(2).MoveFirst
            Range("A1").CopyFromRecordset (Temp(2))
            Temp(1).MoveNext
        Wend
        Temp(0).MoveNext
    Wend
End Sub

 

[vbaInet]

Cheers Paul!

@prabha: you have two options:

1. Use three inner loops with 3 recordsets:

For each Region
    For each Towers
        For each Countries
             ... your code here ...
        Next
    Next
Next

2. Or you use two recordsets, one for looping from top to bottom and the other for outputting. Here, you'll use variables to hold the previous region, previous towers and previous countries. For each record you'll check the previous variables with the current field values and if there's a change you output the previous. A rough idea of what it could look like:

For Each value in Recordset
    if this is the first record ignore check

    else check the current region, towers, and countries here

    end if

    ' save value of region, towers and country
Next

 

[vbaInet]

Or write a recursive function to traverse each Region > Towers > Country. Just like you would do with XML.

 

[prabha_friend]

Good Morning Paul and VbaInet.

Thanks to your code Paul. It rocks. And your suggestions vbaInet.

Private Sub Input_Click()
Dim Mainrset As Recordset
Dim temp As Variant
Set Mainrset = CurrentDb.OpenRecordset("Query_Form")
Mainrset.MoveLast
Mainrset.MoveFirst
ReDim temp(0)
Set temp(0) = CurrentDb.OpenRecordset("SELECT * FROM Regions_Towers;")
temp(0).MoveLast
temp(0).MoveFirst
Excel.Application.Visible = True
Workbooks.Add
While Not temp(0).EOF
'    If Not Sheets(Temp(0).AbsolutePosition + 1) Then Sheets.Add After:=Sheets(Sheets.Count)
    If temp(0).AbsolutePosition > 0 Then Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(temp(0).AbsolutePosition + 1).Name = temp(0)!Region_Name & "-" & temp(0)!Tower_Name
    Mainrset.Filter = "Region_Name = '" & temp(0)!Region_Name & "' AND Tower_Name='" & temp(0)!Tower_Name & "'"
    ReDim Preserve temp(1)
    Set temp(1) = Mainrset.OpenRecordset
    temp(1).MoveLast
    temp(1).MoveFirst
    Range("A1").CopyFromRecordset (temp(1))
    temp(1).MoveFirst 'CopyFromRecordset puts the recordset to EOF
    Range("A:B,E:E").Delete
    ActiveSheet.UsedRange.Copy
    Cells.SpecialCells(xlCellTypeLastCell).Offset(-(Cells.SpecialCells(xlCellTypeLastCell).Row - 1), 1).PasteSpecial Transpose:=True
    Range("A:C").Delete
    If temp(0)!Tower_Name = temp(1)!Process_Name Then
        Rows(2).Delete
    End If
    Cells(1, 1).Select
    temp(0).MoveNext
Wend
End Sub

This is what I have used. I just created a Groupby Query for the Regions and Towers based the Query_Form as All Towers are applicable for some regions.

Currrently struggling to Merge&Center the Continous repetitive Cells.

Sub Merge_and_Center()
Do Until ActiveCell <> ActiveCell.Next
    Union(Selection, ActiveCell.Next).Select
    Selection.Cells(Selection.Cells.Count).Activate
    If Selection.Cells(Selection.Cells.Count) <> ActiveCell.Next Then
        DisplayAlerts = False
        Selection.Merge
        DisplayAlerts = True
        Selection.Cells(Selection.Cells.Count).Next.Activate 'Union brings the first cell as activecell
    End If
Loop
End Sub

The above Merge_and_Center won't work as it keeps putting all as activecell. Is there method to loop only in the UsedRage Like:

Do Until ActiveCell <> ActiveCell.Next In Activesheet.UsedRange

Any Suggestions?

 

[Brianwarnock]

Not having any sample data means that I cannot be fully aware of what you are doing. I would appear that you are tackling 1 row at a time, so what you need to do is amend the code as below.

Sub Merge_and_Center()

Dim lc As Long, cuurentcol As Long

lc = ActiveSheet.UsedRange.Columns.Count
currentcol = 1
Do Until ActiveCell <> ActiveCell.Next
    Union(Selection, ActiveCell.Next).Select
    Selection.Cells(Selection.Cells.Count).Activate
    If Selection.Cells(Selection.Cells.Count) <> ActiveCell.Next Then
        DisplayAlerts = False
        Selection.Merge
        DisplayAlerts = True
        Selection.Cells(Selection.Cells.Count).Next.Activate 'Union brings the first cell as activecell
    End If
    currentcol = currentcol + 1
    If currentcol > lc Then Exit Sub
Loop
End Sub

Brian

I hope this is only for display purposes as merged cells can cause all sorts of problems if more code is to run against them

 

[prabha_friend]

Thanks Brian. In the weekend I have done with following Code:

Sub Merge_and_Center()
Do While Not (Intersect(ActiveCell, ActiveSheet.UsedRange) Is Nothing)
If (ActiveCell = ActiveCell.Next) Then
    Union(Selection, ActiveCell.Next).Select
    Selection.Cells(Selection.Cells.Count).Activate 'Union brings the first cell as activecell
Else
    If Selection.Cells.Count > 1 Then
        Application.DisplayAlerts = False
        Selection.Merge
        Application.DisplayAlerts = True
    End If
    If Intersect(ActiveCell.Next, ActiveSheet.UsedRange) Is Nothing Then Rows(ActiveCell.Row + 1).Cells(1).Activate Else ActiveCell.Next.Activate
End If
Loop
End Sub

 

[Brianwarnock]

Thanks for coming back with your solution. Don't know why I didn't think to use Intersect as we solved that problem in a prior thread, guess I'm getting to old to change my ways.

Brian

 

[prabha_friend]

Prabhakaran

 

[vbaInet]

... guess I'm getting to old to change my ways.

Brian

I'm sure the proverb "you can't teach an old dog new tricks" doesn't apply to you Brian. You need a holiday

@prabha: Just wanted to point out that you should be fully qualifying your reference to include the object you used to open/create the Excel instance.

 

[Brianwarnock]

I'm sure the proverb "you can't teach an old dog new tricks" doesn't apply to you Brian. You need a holiday

Oh! I can learn new tricks , it's remembering them that is the problem.

Brian

 

[vbaInet]

Oh! I can learn new tricks , it's remembering them that is the problem.

Brian

It's high time you create a database to store your thoughts!

Won't it be nice to have a head gear you can wear before going to bed which will upload a copy of your memory for that day!