copy or remove particular count of records and pasting in another excel workbook

Hi perusjosh

Here's a VBA solution

Option Explicit

Sub Get_Three()
    Dim ws As Worksheet, ws1 As Worksheet
    Dim LR As Long, LR1 As Long, x As Long
    Dim Rng As Range, cel As Range

    Set ws = Sheets("original file") '<----Change Sheet Name as required
    Set ws1 = Sheets("OutPut")       '<----Change Sheet Name as required

    Application.ScreenUpdating = False
    With ws1
        .UsedRange.Offset(1, 0).Clear
    End With

    If Not Evaluate("ISREF(Lists!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
        ActiveSheet.Range("A1").Value = "Webaddress"
        ActiveSheet.Range("B1").Value = "Email Address"
    Else
        Sheets("Lists").UsedRange.Offset(1, 0).ClearContents
    End If
    With ws
        LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row

        .Range("A1:A" & LR).Copy
        With Sheets("Lists")
            .Range("A1").PasteSpecial (xlPasteValues)
            .Range(("A1"), .Range("A1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
            ActiveWorkbook.Names.Add Name:="Webaddress", RefersTo:= _
                    "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
        End With
        If Not .AutoFilterMode Then
            .Range("A1").AutoFilter
        End If
        With .Range("A1:A" & LR)
            For Each cel In Range("Webaddress")
                .AutoFilter Field:=1, Criteria1:=cel.Value

                Set Rng = ws.AutoFilter.Range
                x = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
                If x <= 3 Then
                    With ws1
                        LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious).Row + 1
                    End With
                    .Range("A2:B" & LR).SpecialCells(xlCellTypeVisible).Copy
                    ws1.Range("A" & LR1).PasteSpecial (xlPasteValues)
                    ws1.Range("C" & LR1).Resize(x, 1).Value = x
                Else
                    With ws1
                        LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious).Row + 1
                    End With
                    .Range("A2:B" & LR).SpecialCells(xlCellTypeVisible).Copy
                    ws1.Range("A" & LR1).PasteSpecial (xlPasteValues)
                    ws1.Range("C" & LR1).Resize(x, 1).Value = 3
                    ws1.Range("A" & LR1 + 3).Resize(x, 1).EntireRow.Delete
                End If
            Next cel
        End With
        .ShowAllData
    End With
    ws1.Activate
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub