оптимизировать макрос

[Kek]

В макросах не силён. Сделал просто повторение действий руками, но очень много лишнего. Точнее повторяющегося.
Подскажите, как избавиться от повторяющихся элементов.
работает: откр 20-80.xls и запускаем a_exp_00

[kuklp]

Так:

Public Sub www()
    Dim i&, s$
    On Error Resume Next ' если файла или листа не найдет
    For i = 1 To 15
        s = "r" & Format(i, "00")
        With GetObject(ThisWorkbook.Path & "\" & s & ".xls")
            .Sheets(1).UsedRange.Copy Sheets(s).[a1]: .Close 0
        End With
    Next
End Sub

[Hugo121]

Сергей - а ВПРЫ?
Я вот думаю, что эти листы, копирование и ВПРы вообще не нужны - взяли файл, посчитали кодом повторы и общее количество, забили на первый лист...

[kuklp]

Гы) Игорь, я до них не дочитал

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

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

Просто подсказал. Надеюсь, автор дополнит нужным.

[Hugo121]

ИМХО достаточно, но судить конечно не мне

Sub tt()
    Dim FSO
    Dim TheFolder, TheFiles, AFile

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TheFolder = FSO.GetFolder(ThisWorkbook.Path & "\")    'Каталог
    Set TheFiles = TheFolder.Files
    For Each AFile In TheFiles
        If UCase(FSO.GetExtensionName(AFile.Path)) = "XLS" And _
           AFile.Name <> ThisWorkbook.Name Then
            work AFile
        End If
    Next

End Sub

Sub work(n)
    Dim nm$, r As Range, a(), el, cnt1&, cnt2&, t$
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        nm = Split(n.Name, ".xls")(0)
        Set r = ThisWorkbook.Sheets(1).Rows(3).Find(nm, , xlValues, xlWhole)
        If Not r Is Nothing Then
            With CreateObject("scripting.dictionary")
                .comparemode = 1
                a = Range(r.Offset(1), r.End(xlDown)).Value
                For Each el In a: .Item(CStr(el)) = 0&: Next
                Set wb = GetObject(n)
                a = wb.Sheets(1).UsedRange.Value
                wb.Close 0
                For i = 1 To UBound(a)
                    If .exists(Trim(a(i, 1))) Then cnt1 = cnt1 + 1
                    t = Trim(a(i, 16))
                    If Len(t) Then
                        If IsNumeric(t) Then cnt2 = cnt2 + 1
                    End If
                Next
            End With
            r.Offset(1, 16) = cnt1
            r.Offset(5, 16) = cnt2
        End If

        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

[Kek]

Огромное спасибо, то что нужно.
Сейчас тестирую.

[Kek]

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

ИМХО достаточно, но судить конечно не мне

Sub tt()
    Dim FSO
    Dim TheFolder, TheFiles, AFile

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TheFolder = FSO.GetFolder(ThisWorkbook.Path & "\")    'Каталог
    Set TheFiles = TheFolder.Files
    For Each AFile In TheFiles
        If UCase(FSO.GetExtensionName(AFile.Path)) = "XLS" And _
           AFile.Name <> ThisWorkbook.Name Then
            work AFile
        End If
    Next

End Sub

Sub work(n)
    Dim nm$, r As Range, a(), el, cnt1&, cnt2&, t$
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        nm = Split(n.Name, ".xls")(0)
        Set r = ThisWorkbook.Sheets(1).Rows(3).Find(nm, , xlValues, xlWhole)
        If Not r Is Nothing Then
            With CreateObject("scripting.dictionary")
                .comparemode = 1
                a = Range(r.Offset(1), r.End(xlDown)).Value
                For Each el In a: .Item(CStr(el)) = 0&: Next
                Set wb = GetObject(n)
                a = wb.Sheets(1).UsedRange.Value
                wb.Close 0
                For i = 1 To UBound(a)
                    If .exists(Trim(a(i, 1))) Then cnt1 = cnt1 + 1
                    t = Trim(a(i, 16))
                    If Len(t) Then
                        If IsNumeric(t) Then cnt2 = cnt2 + 1
                    End If
                Next
            End With
            r.Offset(1, 16) = cnt1
            r.Offset(5, 16) = cnt2
        End If

        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

я не затронул вопрос, если дата меняется, то и данные изменяются в таблице "процент совпадения отсканированного товара с бестселлерами". а данные за предыдущий день 0.
что добавить, чтобы данные оставались за предыдущие дни?

[Kek]

макрос отрабатывает отлично. сейчас разбираюсь, как вытягивать данные из папок по датам.
но остался вопрос по копированию обнолённых данных:
испробовал несколько вариантов, но ни один и них не подошёл.
в книге 20-80 после обновления данных копировались эти данные в таблицу по дате, которая находится ниже. по сути это будет обновлять каждый день.