Копировать, вставляя ячейки, когда они равны другой электронной таблице, используя макрос

Question

У меня есть рабочий вопрос, и я хочу, чтобы мой макрос сделал следующее

У меня есть два столбца (столбцы A и B). Столбец A имеет имена, а столбец B содержит их информацию.

Я хочу, чтобы мой макрос нашел повторяющиеся имена, скопировал столбцы A и B и вставил их в другую электронную таблицу в следующем месте

C: \ Users \ kentan \ Desktop \ Управляемый фонд

Каждая созданная электронная таблица должна содержать имя этого имени в качестве имени файла

Я создал макрос для следующих действий, но он не дает правильного результата

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

Answer 1

Учитывая повторяющееся действие добавления нескольких рабочих книг, я перенесу эту операцию в подпрограмму «помощник».

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