Макрос перестает работать после создания новой книги

Question

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

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

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

C:\Users\kentan\Desktop\Managed Fund

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

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

Он также не помещает его в папку управляемого фонда (помещая их вместо этого на рабочий стол), И его единственную копию вставляют ОДНОЙ СТРОКОЙ в другую электронную таблицу

Итак, моя таблица выглядит так

Investment Advisor  Managed Fund
Fidelity 1          Fidelity 20
Fidelity 1          Fidelity 21
PIMCO               PIMCO 22
PIMCO               PIMCO 23
PIMCO               PIMCO 24

то, что сделал макрос, создало электронную таблицу с верностью 1 и поместило только в

Fidelity 1  Fidelity 21 

вместо всех фондов верности. Можете ли вы сказать мне, почему?

Option Explicit

Public Const strSA As String = "C:\Users\tempo\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 .Cells(.Rows.Count, 1).End(xlUp).row
        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
    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

Answer 1

Ваша проблема, вероятно, в том, что Sub newiris() закрывает рабочую книгу. Я не совсем понимаю, как называются макросы, но я знаю, что часто, когда вы закрываете книгу, код перестает работать.

Попробуйте создать книги в одном подпункте, а затем закройте их все сразу. Приведенный ниже код может перестать работать после закрытия первой книги, но по крайней мере вы создали каждую книгу.

Option Explicit

Public Const strSA As String = "C:\Users\tempo\Desktop\Managed Fund "
Public newWorkbooks As Collection

Sub iris()
    Dim i As Long
    Dim nm As String
    Set newWorkbooks = New Collection

    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 .Cells(.Rows.Count, 1).End(xlUp).Row
        nm = .Cells(i, "A").Value2
        If LCase(nm) = LCase(.Cells(i - 1, "A").Value2) _
        And _
           LCase(nm) <> LCase(.Cells(i + 1, "A").Value2) _
        Then
            newWorkbooks.Add ("Managed Fund " + nm + ".xlsx")
            newiris nm, .Cells(i, "B").Value2
        End If
        Next
    End With

    CloseWorkbooks

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
    End With
End Sub

Sub CloseWorkbooks()
    Dim i As Integer
    Dim wb As Workbook

    For i = 1 To (newWorkbooks.Count)

        Set wb = Workbooks(newWorkbooks(i))
        wb.Close savechanges:=False

    Next i
    Application.DisplayAlerts = True
End Sub