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

You have not received any responses because your explanation is not clear. Please provide a sample of the what the solution should look like. (prepared manually) No one knows what your logic is to achieve your expected solution. Help us to help you with more information and examples of the solution.

Alan

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

Use another helper column, D

Cell D4:

Formula:

=COUNTIF($A$2:$A2,$A2) 

and drag down.

Filter column D on less than or equal to 3. Copy visible records to the new sheet.

Regards, TMS


Edit: error in formula ... change $A$2,$A2,$A2 to $A$2:$A2,$A2

Another VBA solution:

Option Explicit

Sub sCopyEMailAddresses()

Dim lLR As Long

Application.ScreenUpdating = False

' using sheet1 ...
With Sheet1
    ' determine how many rows of data (based on column A)
    lLR = .Range("A" & .Rows.Count).End(xlUp).Row
    ' add helper formula in column C
    .Range("C2:C" & lLR).Formula = _
        "=COUNTIF($A$2:$A2,$A2)"
    ' filter the records
    With .Range("$A$1:$C$" & lLR)
        .AutoFilter
        .AutoFilter _
            Field:=3, _
            Criteria1:="<=3"
    End With
End With

' prepare sheet2 ...
With Sheet2
    ' clear existng data
    .Cells.Delete
End With

' back on sheet1 ...
With Sheet1
    ' copy visble cells in columns A and B to sheet2
    With .Range("$A$1:$B$" & lLR)
        .SpecialCells(xlCellTypeVisible).Copy _
            Sheet2.Range("A1")
        ' switch off the filter
        .AutoFilter
        ' remove the helper column
        .Range("C1").EntireColumn.Delete
    End With
End With

' and back on sheet2 ...
With Sheet2
    ' make the columsn the right width
    .Range("A1:B1").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

End Sub

Regards, TMS

Ah ... scope creep. In reality, you have had several solutions to your original question and, as such, this thread should now be marked solved.

I am assuming that you are only going to want to vary the number of records extracted occasionally so, rather than add the overhead of front end code which will rarely be used, you might just as well edit the filter.

For example, in my code, you would change:

            Criteria1:="<=3"

to:

            Criteria1:="<=5"

You should also bear in mind that my code simply automates the manual solution offered in post #5.


If you really need the additional code, I would suggest you ask for it in a separate thread.


Regards, TMS


If you are satisfied with the solution(s) provided, please mark your thread as Solved.


New quick method:
Select Thread Tools-> Mark thread as Solved. To undo, select Thread Tools-> Mark thread as Unsolved.

Or you can use this way:

How to mark a thread Solved
Go to the first post
Click edit
Click Go Advanced
Just below the word Title you will see a dropdown with the word No prefix.
Change to Solved
Click Save


You may also want to consider thanking those people who helped you by clicking on the little star at the bottom left of their reply to your question.

OK, maybe this:

Option Explicit

Sub sCopyEMailAddresses()

Dim lLR As Long
Dim sHowMany As String
Dim lHowMany As Long

sHowMany = InputBox("Please enter the maximum number of EMail addresses to be copied", _
                    "Maximum EMail Addresses", _
                    3)

If Trim(sHowMany) = "" Or sHowMany = "0" Then Exit Sub

lHowMany = sHowMany

Application.ScreenUpdating = False

' using sheet1 ...
With Sheet1     ' original file
    ' determine how many rows of data (based on column A)
    lLR = .Range("A" & .Rows.Count).End(xlUp).Row
    ' add helper formula in column C
    .Range("D2:D" & lLR).Formula = _
        "=COUNTIF($A$2:$A2,$A2)"
    ' filter the records
    With .Range("$A$1:$D$" & lLR)
        .AutoFilter
        .AutoFilter _
            Field:=4, _
            Criteria1:="<=" & lHowMany
    End With
End With

' prepare sheet2 ...
With Sheet2     ' required records
    ' clear existing data
    .Cells.Delete
End With

' back on sheet1 ...
With Sheet1     ' original file
    ' copy visble cells in columns A and B to sheet2
    With .Range("$A$1:$C$" & lLR)
        .SpecialCells(xlCellTypeVisible).Copy _
            Sheet2.Range("A1")
        ' switch off the filter
        .AutoFilter
        ' remove the helper column
        .Range("D1").EntireColumn.Delete
    End With
End With

' and back on sheet2 ...
With Sheet2     ' required records
    ' make the columns the right width
    .Range("A1:C1").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

End Sub

Regards, TMS

Thought I'd already done this ...

Suspect the forum problems prevented the upload.

See attached example

Regards, TMS