Copy pasting the cells when they are equal to another spreadsheet using Macro

Question

I have a work question and i want my macro to do the following

i have two columns (column A and B). Column A has the names and column B contains their info.

I want my macro to find duplicate names and copy both col A and B and paste them into another spreadsheet in the following location

C:\Users\kentan\Desktop\Managed Fund

Each spreadsheet created must contain the name of that name as the file name

I have create the macro to do the following but it's not giving me the right result

Sub IRIS()
Dim i As Integer
With ActiveSheet.Sort
.SetRange Range("A:B")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlStroke
.Apply
 End With

i=1

Do Until Len(Cells(i, 1).Value) = 0
If Cells(i, 1).Value = Cells(i + 1, 1).Value Then
Range(Cells(i, 1), Cells(i, 2)).Select
Selection.Copy
Workbooks.Add
Range("A1").PasteSpecial

ActiveWorkbook.SaveAs Filename:= _
"C:\Users\kentan\Desktop\Managed Fund" & cells(i,1) & ".xls"
ActiveWorkbook.Close
Else
    i = i + 1
End If
Loop
Application.CutCopyMode = False
End Sub

Unknown Unknown · Accepted Answer · 2018-05-02T23:00:45

Given the repetitious action of adding multiple workbooks, I would shovel that operation to a 'helper' sub.

Option Explicit

Public Const strSA As String = "C:\Users\kentan\Desktop\Managed Fund "

Sub iris()
    Dim i As Long
    With ActiveSheet
        With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp).Offset(0, 1))
            .Sort key1:=.Columns(1), order1:=xlAscending , _
                  key2:=.Columns(2), order2:=xlAscending , _
                  Header:=xlYes, MatchCase:=False, _
                  Orientation:=xlTopToBottom, SortMethod:=xlStroke
        End With

        For i = 2 To .Rows.Count
            If LCase(.Cells(i, "A").Value2) = LCase(.Cells(i - 1, "A").Value2) And _
               LCase(.Cells(i, "A").Value2) <> LCase(.Cells(i + 1, "A").Value2) Then
                newiris .Cells(i, "A").Value2, .Cells(i, "B").Value2
            End If
        Next i
    End With
End Sub

Sub newiris(nm As String, nfo As String)
    Application.DisplayAlerts = false
    With Workbooks.Add
        Do While .Worksheets.Count > 1: .Worksheets(2).Delete: Loop
        .Worksheets(1).Cells(1, "A").Resize(1, 2) = Array(nm, nfo)
        .SaveAs filename:=strSA & nm, FileFormat:=xlOpenXMLWorkbook
        .Close savechanges:=False
    End With
    Application.DisplayAlerts = true
End Sub

Copy pasting the cells when they are equal to another spreadsheet using Macro

1 Answers