Как заставить код работать во всех книгах указанной папки

[KNatalia]

Всем привет!
Подскажите, пожалуйста, что не так!
Мне нужно, чтобы один и тот же макрос выполнялся во всех книгах в одной папке одновременно.
Сам макрос расположен в файле МАКРОС. Макрос выполняет суммирование по облигациям рыночной стоимости и НКД.

Код:


Sub Auto_Whrite_In_Books()
Dim sFolder As String, sFiles As String, li As Long
With Application.FileDialog(msoFileDialo gFolderPicker)
If .Show = False Then Exit Sub
sFolder = .SelectedItems(1)
End With
Application.ScreenUpdating = False
sFiles = Dir(sFolder & Application.PathSeparator & "*.xlsx")
Do While sFiles <> ""
Workbooks.Open sFiles

Dim i As Double, n As Double
For i = ActiveWorkbook.Sheets(1).Cells.Find ("Облигации").Row + 1 To ActiveWorkbook.Sheets(1).Cells.Find ("Итого Облигации предприятий:").Row - 1
For n = ActiveWorkbook.Sheets(1).Cells.Find ("% по облигациям").Row + 1 To ActiveWorkbook.Sheets(1).Cells.Find ("Итого % по облигациям:").Row - 1
If Mid(Cells(n, 1), InStr(Cells(n, 1), "№")) & "; " = Mid(Cells(i, 1), InStr(Cells(i, 1), "№")) Then
Cells(i, 29) = Cells(i, 29) + Cells(n, 29)
Cells(i, 29).NoteText "= A" & i & "+ A" & n & ""
Exit For
End If: Next: Next:


ActiveWorkbook.Close True
sFiles = Dir
Loop
Application.ScreenUpdating = True
End Sub


ПОДСКАЖИТЕ, что не так?
ОШИБОК НЕТ, НО И НЕ РАБОТАЕТ!

Заранее большое спасибо

[EducatedFool]

Вот так будет работать:

Sub Auto_Write_In_Books()
    Dim sFolder As String, sFiles As String, li As Long
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & Application.PathSeparator & "*.xls*")
    On Error Resume Next
    Do While sFiles <> ""
        Workbooks.Open sFiles

        Dim i As Double, n As Double
        For i = ActiveWorkbook.Sheets(1).Cells.Find("Облигации").Row + 1 To ActiveWorkbook.Sheets(1).Cells.Find("Итого Облигации предприятий:").Row - 1
            For n = ActiveWorkbook.Sheets(1).Cells.Find("% по облигациям").Row + 1 To ActiveWorkbook.Sheets(1).Cells.Find("Итого % по облигациям:").Row - 1
                If Mid(Cells(n, 1), InStr(Cells(n, 1), "№")) & "; " = Mid(Cells(i, 1), InStr(Cells(i, 1), "№")) Then
                    Cells(i, 29) = Cells(i, 29) + Cells(n, 29)
                    Cells(i, 29).NoteText "= A" & i & "+ A" & n & ""
                    Exit For
                End If: Next: Next:
        ActiveWorkbook.Close True
        sFiles = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Раньше макрос искал только файлы Excel 2007:
sFiles = Dir(sFolder & Application.PathSeparator & "*.xlsx")

[KNatalia]

Спасибо большое!
Только теперь он ошибку пишет:
Invalide procedure call or argument в строчке

If Mid(Cells(n, 1), InStr(Cells(n, 1), "№")) & "; " = Mid(Cells(i, 1), InStr(Cells(i, 1), "№")) Then

[KNatalia]

Правда ошибка выдается только для одного файла ПИ_TIP
Если его удалить из папки, то макрос работает!

В чем проблема с данным файлом?

[EducatedFool]

В чем проблема с данным файлом?

Вы не заметили, что я в код макроса добавил ещё одну строку: On Error Resume Next ?

Ошибку вызывает эта часть кода:

Mid(Cells(i, 1), InStr(Cells(i, 1), "№"))

В одной из ячеек нет символа №
Соответственно, InStr(Cells(i, 1), "№") возвращает 0
А функция Mid не может считать текст, начиная с нулевой позиции...

[Teslenko_EA]

Здравствуйте Наталья.
Код вполне работоспособный

Sub Auto_Whrite_In_Books()
Const s1 = "Облигации", s2 = "Итого Облигации предприятий:"
Const s3 = "% по облигациям", s4 = "Итого % по облигациям:"
Dim sFolder$, sFiles$, li&, oWB As Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = False Then Exit Sub
    sFolder = .SelectedItems(1)
End With
Application.ScreenUpdating = False
On Error Resume Next
sFiles = Dir(sFolder + "\*.xls") '+ "\*.xlsx" 'выложенные Вами файлы, формата Е 2003
Do While Len(sFiles) > 0
    If Not ThisWorkbook.Name = sFiles Then 
    'если не выполнять эту проверку в случае если обращаться к папке с файлом
    ' МАКРОС.xls, произойдет попытка повторного открытия файла - выполнение процедуры прервется
        Set oWB = Workbooks.Open(sFiles)
        Dim i#, n#, j#, q#, k#, f#
        With oWB
            With .Sheets(1).Cells
                j = .Find(s1).Row
                q = .Find(s2).Row
                k = .Find(s3).Row
                f = .Find(s4).Row
            End With
            If Not j * q * k * f = 0 Then ' стоит проверить всё ли найдено
                For i = j + 1 To q - 1
                    For n = k + 1 To f - 1
                        'здесь код которого я не понимаю
                        'Cells(i, 29) = Cells(i, 29) + Cells(n, 29)
                        'такой способ "накопления" не корректен
                        'т.к. зависит от кол-ва выполнений процедуры
                    ' End If
                    Next
                Next
            End If
        End With
        oWB.Close True
    End If
    sFiles = Dir()
Loop
Application.ScreenUpdating = True
End Sub

но позволю себе сделать пару рекомендаций:
Вынос текста в константы не только уменьшает нагрузку кода избавляя от необходимости неоднократной интерпретации, но и делает код более удобочитаемым.
Использование переменных для однократного присвоения значения объекта лучше чем многократное обращение к объекту - "For i = ActiveWorkbook.Sheets(1).Cells" в цикле.
Евгений.
P.S. код заключенный в тэги [соde] ... [/соde] будет тоже "более удобочитаемым".

[KNatalia]

Огромное Вам всем спасибо за помощь, за разъяснения и подсказки!
Очень многому меня научили!

С самыми наилучшими пожеланиями, Наталья

[1134]

Классно, отличная тема!

[ertree]

Сообщение от EducatedFool

Вот так будет работать:

Sub Auto_Write_In_Books()
    Dim sFolder As String, sFiles As String, li As Long
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & Application.PathSeparator & "*.xls*")
    On Error Resume Next
    Do While sFiles <> ""
        Workbooks.Open sFiles

        Dim i As Double, n As Double
        For i = ActiveWorkbook.Sheets(1).Cells.Find("Облигации").Row + 1 To ActiveWorkbook.Sheets(1).Cells.Find("Итого Облигации предприятий:").Row - 1
            For n = ActiveWorkbook.Sheets(1).Cells.Find("% по облигациям").Row + 1 To ActiveWorkbook.Sheets(1).Cells.Find("Итого % по облигациям:").Row - 1
                If Mid(Cells(n, 1), InStr(Cells(n, 1), "№")) & "; " = Mid(Cells(i, 1), InStr(Cells(i, 1), "№")) Then
                    Cells(i, 29) = Cells(i, 29) + Cells(n, 29)
                    Cells(i, 29).NoteText "= A" & i & "+ A" & n & ""
                    Exit For
                End If: Next: Next:
        ActiveWorkbook.Close True
        sFiles = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Раньше макрос искал только файлы Excel 2007:
sFiles = Dir(sFolder & Application.PathSeparator & "*.xlsx")

Перестал работать код по применению кода к файлам папки в виндовс 7. Кто-нибудь сталкивался с такой проблемой? Как можно решить?

[EducatedFool]

ertree, данный код должен работать в любой версии Windows.
Возможно, вы как-то не так его используете?

В чем проявляется проблема?
Выскакивает ошибка? Если да, то на какой строке?