Макрос имен файлов excel

The_Fog

0 / 0 / 2

Регистрация: 24.02.2016

Сообщений: 75

1

30.01.2017, 12:58. Показов 27705. Ответов 18

Метки нет (Все метки)


Студворк — интернет-сервис помощи студентам

Скрипт должен получить имя активного файла, создать его копию, и в копии имени заменить некоторые символы.
Например файл назывался «12File_Name.xlsm» нужно создать копию с именем «!55File_Name.xlsm». Подскажите как реализовать такую замену символов в имени.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Sub Create_xls()
Sheets(1).Copy
With ActiveWorkbook
With .Sheets(1)
.Rows("11:" & .Rows.Count).Delete
.Columns("E:IV").Delete
End With
.SaveAs Filename:=ThisWorkbook.Path & "!55" & "ThisWorkbook.Name"
.Close True
End With
End Sub

т.е. проблема со строчкой

Visual Basic
1
.SaveAs Filename:=ThisWorkbook.Path & "!55" & "ThisWorkbook.Name"

Добавлено через 28 минут
Вот нашел на форуме такое решение

Visual Basic
1
.SaveAs Filename:=ThisWorkbook.Path & "!" & Replace(ActiveDocument.Name, "23", "55")

Но пишет ошибку Run-time error ‘424’ Object required.

=(



0



3217 / 966 / 223

Регистрация: 29.05.2010

Сообщений: 2,085

30.01.2017, 13:58

2

Цитата
Сообщение от The_Fog
Посмотреть сообщение

Replace(ActiveDocument.Name

А причем здесь ActiveDocument?



0



The_Fog

0 / 0 / 2

Регистрация: 24.02.2016

Сообщений: 75

30.01.2017, 14:15

 [ТС]

3

Я так понял

PureBasic
1
ActiveDocument.Name

с помощью этой функции можно получить имя файла. Если нет подскажите пожалуйста как получить это имя и заменить в нем пару символов.



0



toiai

3217 / 966 / 223

Регистрация: 29.05.2010

Сообщений: 2,085

30.01.2017, 14:19

4

Цитата
Сообщение от The_Fog
Посмотреть сообщение

ActiveDocument.Name

Это Word документ…
может так

Visual Basic
1
ThisWorkbook.Name



0



The_Fog

0 / 0 / 2

Регистрация: 24.02.2016

Сообщений: 75

30.01.2017, 14:37

 [ТС]

5

Visual Basic
1
ThisWorkbook.Name

Не не не, я тоже думал что так, но не так =(

Тоже выдает ошибку =(



0



6875 / 2807 / 533

Регистрация: 19.10.2012

Сообщений: 8,562

30.01.2017, 14:40

6

ThisWorkbook — это не активная книга, а книга с кодом, не факт что они совпадают!



0



The_Fog

0 / 0 / 2

Регистрация: 24.02.2016

Сообщений: 75

30.01.2017, 15:22

 [ТС]

7

обе функции ошибку выдают

Visual Basic
1
.SaveAs Filename:=ThisWorkbook.Path & "!" & Replace(ActiveDocument.Name, "23", "55")



0



CyberHelp

6 / 6 / 1

Регистрация: 29.01.2017

Сообщений: 29

30.01.2017, 15:27

8

Visual Basic
1
2
3
4
5
6
Public Sub Fog()
Dim Fog1, Fog2 As String
Fog1 = ActiveWorkbook.Name
Fog2 = ActiveWorkbook.Path
ActiveWorkbook.SaveAs Filename:=Fog2 + "!55" + Fog1
End Sub

Этот макрос скопирует вам активный файл excel в ту же директорию, где находится активный файл, при этом активный файл (например «файл1») будет закрыт и будет открыто окно сохраненного файла (например «!55файл1»).

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



0



0 / 0 / 2

Регистрация: 24.02.2016

Сообщений: 75

30.01.2017, 16:53

 [ТС]

9

не получается ошибка…



0



6 / 6 / 1

Регистрация: 29.01.2017

Сообщений: 29

30.01.2017, 17:30

10

1) Скиньте скриншот.
2) Вы код куда сохранили код макросов? В личную книгу макросов PERSONAL.XLSB?

У меня всё отлично работает.



0



6 / 6 / 1

Регистрация: 29.01.2017

Сообщений: 29

30.01.2017, 17:37

11

Вот вложил файл. Зайдите и нажмите на кнопку.
К кнопке привязан код.



1



pashulka

4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

30.01.2017, 18:13

12

The_Fog, Если проблема только в имени нового файла, то :

Visual Basic
1
2
3
4
5
6
Private Sub Test()
    Worksheets(1).Copy
    Rows("11:" & Rows.Count).Delete
    Columns("E:" & Columns.Count).Delete
    ActiveWorkbook.Close True, Replace(ThisWorkbook.FullName, "12", "!55")
End Sub



1



The_Fog

0 / 0 / 2

Регистрация: 24.02.2016

Сообщений: 75

31.01.2017, 12:51

 [ТС]

13

Visual Basic
1
2
3
4
5
6
Public Sub Fog()
Dim Fog1, Fog2 As String
Fog1 = ActiveWorkbook.Name
Fog2 = ActiveWorkbook.Path
ActiveWorkbook.SaveAs Filename:=Fog2 + "!55" + Fog1
End Sub

Этот макрос скопирует вам активный файл excel в ту же директорию, где находится активный файл, при этом активный файл (например «файл1») будет закрыт и будет открыто окно сохраненного файла (например «!55файл1»).

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

Ваш код работает, а у меня почему то нет

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Create_xls()
Dim Fog1, Fog2 As String
 Fog1 = ActiveWorkbook.Name
Fog2 = Replace(Fog1, "ÆÄÓ", "ÝèÔ")
Sheets(1).Copy
With ActiveWorkbook
With .Sheets(1)
.Rows("11:" & .Rows.Count).Delete
.Columns("E:IV").Delete
End With
'ActiveWorkbook.Close True, Replace(ThisWorkbook.FullName, "ÆÄÓ.xlsm", "ÝèÔ.xlsm")
 
'.SaveAs Filename:=ThisWorkbook.Path & "!" & Replace(ThisWorkbook.FullName, "ÆÄÓ", "ÝèÔ")
.SaveAs Filename:=ThisWorkbook.Path & "!" + "Fog2"
.Close True
End With



0



Hugo121

6875 / 2807 / 533

Регистрация: 19.10.2012

Сообщений: 8,562

31.01.2017, 12:52

14

The_Fog, что напишет

Visual Basic
1
msgbox ThisWorkbook.FullName



0



6 / 6 / 1

Регистрация: 29.01.2017

Сообщений: 29

31.01.2017, 17:11

15

Попробуйте заменить & на + везде



0



6875 / 2807 / 533

Регистрация: 19.10.2012

Сообщений: 8,562

31.01.2017, 17:15

16

CyberHelp, вообще обычно рекомендуют делать наоборот



0



6 / 6 / 1

Регистрация: 29.01.2017

Сообщений: 29

31.01.2017, 17:24

17

Мой код тоже не работал пока я & не заменил на + :-D



0



6875 / 2807 / 533

Регистрация: 19.10.2012

Сообщений: 8,562

31.01.2017, 17:26

18

Это интересно, не слышал о таком казусе. Это на какой системе такое?



0



The_Fog

0 / 0 / 2

Регистрация: 24.02.2016

Сообщений: 75

01.02.2017, 17:12

 [ТС]

19

Ошибка в моем коде была…
Вот правильный вариант :

Visual Basic
1
2
3
4
5
6
7
8
Sub Create_xls()
With ActiveWorkbook
With .Sheets(1)
.Rows("150:" & .Rows.Count).Delete
.Columns("Q:IV").Delete
End With
 
.SaveAs Filename:=.Path & "!" & Replace(.Name, "ЖДУ.xlsm", "ЭиФ.xlsm")



0



IT_Exp

Эксперт

87844 / 49110 / 22898

Регистрация: 17.06.2006

Сообщений: 92,604

01.02.2017, 17:12

19

In this guide, we’re going to show you how to get filename from path in Excel. We will cover how to do this with and without VBA.

Download Workbook

File path and file name

A file path is a string identifier that specifies the unique location in a file system. It contains folders in a hierarchical order following by a file name. Each element is separated by a delimiter which is usually a backslash «». The goal of getting filename from path is to parse that filename after the last delimiter.

Warning: If your paths contain another separator, update the formulas by replacing backslash («») with the separator character fits your case.

We will show you four different approaches to get filename from path in Excel.

Conservative method

Our first approach is using well known Excel functions MIN, SUBSTITUE and LEN to get the file name. You can use this formula in any Excel version.

=MID(<path>,FIND(«*»,SUBSTITUTE(<path>,»»,»*»,LEN(<path>)-LEN(SUBSTITUTE(<path>,»»,»»))))+1,LEN(<path>))

This formula has couple of steps:

  1. At the inner section, all separators («») get replaced with empty strings.
  2. The formula subtracts the length of substituted path (1) from original path to find the number of separators.
  3. The outer SUBSTITUTE function replaces the last separator («») with «*». Obviously, the last separator’s instance is equal to number of separators (2).
  4. Finally, the FIND locates the «*» character, and the MID function parses the file name after the character.

How to get filename from path in Excel 02 - Conservative

VBA with FileSystemObject

You can use VBA to create your own custom functions which you can use in worksheet as well. Of course, you can use this function in your macros as well.

The code is very short. It uses GetFileName method of FileSystemObject object. The important section of the code is the initializing of the object. The following code sets FileSystemObject object to fso variable.

Set fso = CreateObject(«Scripting.FileSystemObject»)

Once the object is initialized, use the GetFileName method by providing the path.

GetFileNameFromPath_FSO = fso.GetFileName(«C:Excel FilesDashboards.xlsm»)

The above line returns «Dashboard.xlsm» string. Here is the function version you can use in your worksheets as well.

Function GetFileNameFromPath_FSO(ByVal Path As String) As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    GetFileNameFromPath_FSO = fso.GetFileName(Path)
End Function

How to get filename from path in Excel 03-VBA

VBA with a recursive function

A recursive function is function which calls itself. The recursive approach acts like an iteration and helps us to parse values starting from the end of a string. You could have used recursive functions only in VBA until the LAMBDA function has been released. Because the most of Excel users do not have access to the LAMBDA function, we will show you VBA version which any Excel user can use.

This function has only few rows as well. The function’s name is GetFilenameFromPath_Recursive and take a single argument named Path.

The first row is a logical test that checks if the last character in the argument is a backslash («») or not and if the argument is not an empty string. If the test is passed, the function returns itself with the argument without its last character and the last character of the path. This is where the recursion occurs.

The function runs itself until coming up a backslash («») or not a character left. It parses the characters from the right side and combines them with each run.

The last row contains a standard End If statement which determines where the If block ends.

Function GetFilenameFromPath_Recursive(ByVal Path As String) As String
    If Right$(Path, 1) <> "" And Len(Path) > 0 Then
        GetFilenameFromPath_Recursive = GetFilenameFromPath_Recursive(Left$(Path, Len(Path) - 1)) & Right$(Path, 1)
    End If
End Function

Using LAMBDA to get filename from path

If you are Microsoft 365 subscriber, you can create recursive functions without using VBA. Briefly, the LAMBDA function is a special function that converts named ranges into user defined functions. Its syntax allows you to define arguments and a custom formula which uses that defined arguments.

For example, let’s say my custom function will have two arguments and returns multiplication of two arguments. All I need to is creating a named range, such as «MyLambda» and enter the following formula into Refers to box.

Syntax Sample Formula Sample Result
=LAMBDA(x, y, x*y) =MyLambda(2,3) 6

If you call the named range «MyLambda» in the «MyLambda» function, you will create a recursive function. Same logic can be applied to VBA function at previous section.

The following is the LAMBDA version of our VBA code. The function’s name is GetFileNameFromPath_Lambda. Check out how the function calls itself after IF function’s logical test.

=LAMBDA(Path,IF(AND(RIGHT(Path,1)<>»»,LEN(Path)>0),GetFileNameFromPath_Lambda(LEFT(Path,LEN(Path)-1))&RIGHT(Path,1),»»))

Warning: Do not forget to update formula name in the formula if you change the named range’s name. Otherwise, the function returns #NAME? error due to incorrect function name.

Using LAMBDA Function with different approach

Alternatively, you can use the LAMBDA function without calling the «function name».  The definition may sound complicated since you must call the function in the function by its name. This structure dictates you to update each occurrence of the name every time change the function’s name.

You can overcome this necessity by using another Microsoft 365-specific function called LET. The LET function allows you to define named ranges in a formula scope. You can define repeating values or blocks into these names and use them continuously.

If you define the name of the LAMBDA function in the formula, you can use the in-formula name over and over to make the function recursive. In our example, we create the name «Func» in the formula and call it within self. Outer LAMBDA function is to give the whatever name we want, «GetFileNameFromPath_LambdaMe».

=LAMBDA(Path,LET(Func,LAMBDA(ME,Path,IF(AND(RIGHT(Path,1)<>»»,LEN(Path)>0),ME(ME,LEFT(Path,LEN(Path)-1))&RIGHT(Path,1),»»)),Func(Func,Path)))

 

Irbis_evs

Пользователь

Сообщений: 337
Регистрация: 30.03.2017

частично, забыл уточнить, что код открывает другой файл, необходимо вернуться обратно.
начало кода:

Код
Dim sh 'As Worksheet, i&, lRow
Dim lSpisok, itable, dSpisok, prod, dd
book = ThisWorkbook.Name
' Настройка списка фильтров
Filt = ("XLS Files(*.xl*),*.xl*")
'Получение имени файла
FileName1 = Application.GetOpenFilename(FileFilter:=Filt)
' При отмене выйти иэ окна
If FileName1 = False Then
MsgBox "Файл не выбран."
End If
Set objCloseBook = GetObject(FileName1)
'objCloseBook.Close False


Windows("123.xlsm").Activate

Worksheets("Список").Select
ActiveSheet.Unprotect
' Отображение полного имени и пути
'MsgBox OpenWorkbook(GetObject(FileName1).Name)

Инженер не тот, кто все знает, а тот кто знает где найти ответ.

Макрос VBA загрузки списка файлов из папки

Функция FilenamesCollection предназначена для получения списка файлов из папки, с учётом выбранной глубины поиска в подпапках.

Используется рекурсивный перебор папок, до заданного уровня вложенности.
В процессе перебора папок, пути у найденным файлам помещаются в коллекцию (объект типа Collection) для последующего перебора.

К статье прикреплено 2 примера файла с макросами на основе этой функции:

  • Пример в файле FilenamesCollection.xls выводит список файлов на чистый лист новой книги (формируя заголовки) 
  • Пример в файле FilenamesCollectionEx.xls более функционален — он, помимо списка файлов из папки, отображает размер файла, и дату его создания, а также формирует в ячейках гиперссылки на найденные файлы.
    Вывод списка производится на лист запуска, параметры поиска файлов задаются в ячейках листа (см. скриншот)

Смотрите также расширенную версию макроса на базе этой функции:

Макрос FolderStructure выводит в таблицу Excel список файлов и подпапок с отображением структуры (вложенности файлов и подпапок)

ПРИМЕЧАНИЕ: Если вы выводите на лист список имен файлов картинок (изображений), то при помощи этой надстройки вы сможете вставить сами картинки в ячейки соседнего столбца (или в примечания к этим ячейкам)

Внимание: если требуется, чтобы поиск не зависел от регистра символов в маске файла
(к примеру, обнаруживались не только файлы .txt, но и .TXT и .Txt),
поставьте первой строкой в модуле директиву Option Compare Text

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' © EducatedFool  excelvba.ru/code/FilenamesCollection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function
 
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        ' Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

‘ Пример использования функции в макросе:

Sub ОбработкаФайловИзПапки()
    On Error Resume Next
    Dim folder$, coll As Collection
 
    folder$ = ThisWorkbook.Path & "Платежи"
    If Dir(folder$, vbDirectory) = "" Then
        MsgBox "Не найдена папка «" & folder$ & "»", vbCritical, "Нет папки ПЛАТЕЖИ"
        Exit Sub        ' выход, если папка не найдена
    End If
 
    Set coll = FilenamesCollection(folder$, "*.xls")        ' получаем список файлов XLS из папки
    If coll.Count = 0 Then
        MsgBox "В папке «" & Split(folder$, "")(UBound(Split(folder$, "")) - 1) & "» нет ни одного подходящего файла!", _
               vbCritical, "Файлы для обработки не найдены"
        Exit Sub        ' выход, если нет файлов
    End If
 
    ' перебираем все найденные файлы
    For Each file In coll
        Debug.Print file        ' выводим имя файла в окно Immediate
    Next
End Sub

Этот код позволяет осуществить поиск нужных файлов в выбранной папке (включая подпапки), и выводит полученный список файлов на лист книги Excel:

Sub ПримерИспользованияФункции_FilenamesCollection()
    ' Ищем на рабочем столе все файлы TXT, и выводим на лист список их имён.
    ' Просматриваются папки с глубиной вложения не более трёх.

    Dim coll As Collection, ПутьКПапке As String
    ' получаем путь к папке РАБОЧИЙ СТОЛ
    ПутьКПапке = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    ' считываем в колекцию coll нужные имена файлов
    Set coll = FilenamesCollection(ПутьКПапке, ".txt", 3)
 
    Application.ScreenUpdating = False    ' отключаем обновление экрана
    ' создаём новую книгу
    Dim sh As Worksheet: Set sh = Workbooks.Add.Worksheets(1)
    ' формируем заголовки таблицы
    With sh.Range("a1").Resize(, 3)
        .Value = Array("№", "Имя файла", "Полный путь")
        .Font.Bold = True: .Interior.ColorIndex = 17
    End With
 
    ' выводим результаты на лист
    For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к файлам
        sh.Range("a" & sh.Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = _
        Array(i, Dir(coll(i)), coll(i))    ' выводим на лист очередную строку
        DoEvents    ' временно передаём управление ОС
    Next
    sh.Range("a:c").EntireColumn.AutoFit    ' автоподбор ширины столбцов
    [a2].Activate: ActiveWindow.FreezePanes = True ' закрепляем первую строку листа
End Sub

Ещё один пример использования:

Sub ЗагрузкаСпискаФайлов()
    ' Ищем файлы в заданной папке по заданной маске,
    ' и выводим на лист список их параметров.
    ' Просматриваются папки с заданной глубиной вложения.

    Dim coll As Collection, ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%
 
    ПутьКПапке$ = [c1]    ' берём из ячейки c1
    МаскаПоиска$ = [c2]    ' берём из ячейки c2
    ГлубинаПоиска% = Val([c3])    ' берём из ячейки c3
    If ГлубинаПоиска% = 0 Then ГлубинаПоиска% = 999    ' без ограничения по глубине

    ' считываем в колекцию coll нужные имена файлов
    Set coll = FilenamesCollection(ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%)
 
    Application.ScreenUpdating = False    ' отключаем обновление экрана

    ' выводим результаты (список файлов, и их характеристик) на лист
    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к файлам

        НомерФайла = i
        ПутьКФайлу = coll(i)
        ИмяФайла = Dir(ПутьКФайлу)
        ДатаСоздания = FileDateTime(ПутьКФайлу)
        РазмерФайла = FileLen(ПутьКФайлу)
 
        ' выводим на лист очередную строку
        Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = _
        Array(НомерФайла, ИмяФайла, ПутьКФайлу, ДатаСоздания, РазмерФайла)
 
        ' если нужна гиперссылка на файл во втором столбце
        ActiveSheet.Hyperlinks.Add Range("b" & Rows.Count).End(xlUp), ПутьКФайлу, "", _
                                   "Открыть файл" & vbNewLine & ИмяФайла
 
        DoEvents    ' временно передаём управление ОС
    Next
End Sub

PS: Найти подходящие имена файлов в коллекции можно при помощи следующей функции:

Function CollectionAutofilter(ByRef coll As Collection, ByVal filter$) As Collection
    ' Функция перебирает все элементы коллекции coll,
    ' оставляя лишь те, которые соответствуют маске filter$ (например, filter$="*некий текст*")
    ' Возвращает коллекцию, содержащую только подходящие элементы
    ' Если элементы не найдены - возвращается пустая коллекция (содержащая 0 элементов)
    On Error Resume Next: Set CollectionAutofilter = New Collection
    For Each Item In coll
        If Item Like filter$ Then CollectionAutofilter.Add Item
    Next
End Function
  • 301873 просмотра

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.

Доброго дня!

Обычно делаю так:

Перед открытием файла, запоминаю параметры исходного:

WBOld = Thisworkbook.Name
WSOld = ActiveSheet.Name

Теперь открываю нужный файл. Естественно, что он после открытия становится активным.
Ну а дальше варианты:
Если мне нужно из этого активного файла переписать данные в файл открывающий (например значение в ячейке E2, вызываемого файла, активный лист), то записываю данные в переменную (-нные) и затем:

  param=0
  param=cells(2,5).Value
  With workbooks(WBOld).Worksheets(WSOld)
     .cells(3,2)=param
     param=0
  End With

В случае, если же мне нужно перейти в вызывающую книгу и вызывающий лист, то так

workbooks(WBOld).activate
Worksheets(WSOld).select

Вот кусок кода:

'собираем перечень использованных в эти даты объектов = Start ===
    'запоминаем исходные книгу и лист
    wobk = ThisWorkbook.Name
    wost = "DayWork"

        'Открываем Tbl&CC.xls
    ''Проверяем не открыта ли она уже,
    fil01 = False
    For Each wbk In Workbooks
        If wbk.Name = "Tbl&CC.xls" Then
            fil01 = True
            Exit For
        End If
    Next
    'если не открыта, то открываем
    If fil01 = False Then
        Application.ScreenUpdating = False '- отключаем обновление экрана
        Application.EnableEvents = False '- отключаем реакцию на события

                Workbooks.Open Filename:="\EnergypoleTbl&CC.xls", ReadOnly:=True, Password:="Wolf" '- только на чтение

                Application.EnableEvents = True '- включаем реакцию на события
    End If

        With Workbooks("Tbl&CC.xls").Worksheets("CCS")
        'определяем занятую данными область листа == Start ==
        Set blok = .UsedRange
        nREnd = blok.Row + blok.Rows.Count - 2
        Set blok = Nothing
        'определяем занятую данными область листа == Stop ==
        If nREnd < 3 Then
            MsgBox "База Табеля [Tbl&CC.xls] - ПУСТА!", vbQuestion + vbOKOnly, ""

                        closeTabel fil01

                        Exit Sub
        End If

                'формируем массив объектов
        k = 0
        ReDim arrNabor(k)
        datT = 0

                i = 0
        For i = nREnd To 4 Step -1
            datT = .Cells(i, 6).Value
            flgT = False
'Stop
            j = 0
            For j = LBound(arrVibor) To UBound(arrVibor)
                If datT = CDate(arrVibor(j)) Then
                    flgT = True
                End If
            Next j

                        If flgT = True Then
'
                datR = .Cells(i, 2).Text
                flgQ = False
                f = 0
                For f = LBound(arrNabor) To UBound(arrNabor)
                    If datR = arrNabor(f) Then
                        flgQ = True
                    End If
                Next f

                            If flgQ = False Then
                    If k > 0 Then
                        ReDim Preserve arrNabor(k)
                    End If
                    arrNabor(k) = datR
                    k = k + 1
                End If
            End If
'
            datT = 0
            datR = ""
        Next i

            End With

        Erase arrVibor

        closeTabel fil01

    Workbooks(wobk).Worksheets(wost).Activate

    'собираем перечень использованных в эти даты объектов = Stop ===

если непонятно — спрашивайте …

Понравилась статья? Поделить с друзьями:
  • Макрос копирование ячеек с листа на лист в excel
  • Макрос или надстройка excel
  • Макрос копирование строки с листа на лист в excel
  • Макрос изменения цвета ячейки в excel при
  • Макрос копирование строк с листа на лист в excel