Correct the vba code.

[satputenandkumar0]

Dear member,

I have below VBA code for output first and last series of the branches from the given data. But it takes more zeros in output. pls help me out from unnecessary zeros.

Sub x()

Dim r As Range, r1 As Range, n As Long, ws1 As Worksheet, ws2 As Worksheet

Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Data1").Delete
On Error GoTo 0
Set ws2 = Sheets.Add()
ws2.Name = "Data1"

Set ws1 = Sheets("Dispatch")
n = ws1.Range("A" & Rows.Count).End(xlUp).Row
ws1.Range("A1").Resize(n).AdvancedFilter xlFilterCopy, , ws2.Range("A1"), unique:=True
ws1.Range("B1").Resize(n).Copy ws2.Range("B1")
For Each r In ws2.Range("B2").Resize(n - 1)
    r = Left(r, 4)
Next r
ws2.Range("B1").Resize(n).AdvancedFilter xlFilterCopy, , ws2.Range("C1"), unique:=True
    
For Each r In ws2.Range("A2", ws2.Range("A" & Rows.Count).End(xlUp))
    For Each r1 In ws2.Range("C2", ws2.Range("C" & Rows.Count).End(xlUp))
        ws1.Range("F" & Rows.Count).End(xlUp)(2) = r
        ws1.Range("G" & Rows.Count).End(xlUp)(2).FormulaArray = "=MIN(IF(LEFT($B$2:$B$500,4)=" & Chr(34) & r1 & Chr(34) & ",IF($A$2:$A$500=" & Chr(34) & r & Chr(34) & ",VALUE(RIGHT($B$2:$B$500,LEN($B$2:$B$500)-1)))))"
        ws1.Range("H" & Rows.Count).End(xlUp)(2).FormulaArray = "=MAX(IF(LEFT($B$2:$B$500,4)=" & Chr(34) & r1 & Chr(34) & ",IF($A$2:$A$500=" & Chr(34) & r & Chr(34) & ",VALUE(RIGHT($B$2:$B$500,LEN($B$2:$B$500)-1)))))"
        ws1.Range("F2").CurrentRegion.Value = ws1.Range("F2").CurrentRegion.Value
    Next r1
Next r

Sheets("Data1").Delete

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Below is the Output from this code.

112	1560901	1560982
112	1890001	1890050
112	0	0
112	1980444	1980445
112	0	0
340	0	0
340	0	0
340	1590001	1590002
340	0	0
340	0	0
704	0	0
704	0	0
704	0	0
704	0	0
704	6030898	6030899

<colgroup><col><col><col></colgroup><tbody>
</tbody>

Regards,
Nandkumar S.

<colgroup><col><col><col></colgroup><tbody>
</tbody>

 

[satputenandkumar0]

Dear Members,
please find attached file.

https://www.dropbox.com/s/53kr4jlj80hjw3y/Copy%20of%20first%20last.xls

 

[satputenandkumar0]

bump. please

 

[satputenandkumar0]

Anyone has solution for this