Файл уже используется excel vba

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125

Function IsOpen(File$) As Boolean
 Dim FN%
 FN = FreeFile
 On Error Resume Next
 Open File For Random Access Read Write Lock Read Write As #FN
Close #FN
 IsOpen = Err
End Function
 
Sub Test()
 Debug.Print IsOpen("....xlsx")
End Sub
 
Sub Get_All_File_from1()
 
 
'убрать окно с  ПредупреждениеОКонфиденциальнойИнформации
ActiveWorkbook.RemovePersonalInformation = 0
If ActiveWorkbook.RemovePersonalInformation Then
    ActiveWorkbook.RemovePersonalInformation = False
End If
 'Отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
 
    
    Dim sFolder As String, sFiles As String, m As Range, s As Integer, i As Integer, wbReturn As Workbook, rFiles As String
'    Адрес папки, где все файлы сотрудников
    sFolder = "..."
    
    sFiles = Dir(sFolder & "*.xlsx")
    
    rFiles = sFolder & sFiles
    
    
    Do While sFiles <> ""
    
    If IsOpen(rFiles) = False Then
    
            'открываем книги сотрудников
            Workbooks.Open sFolder & sFiles
            n = ActiveWorkbook.Name
            'действия с файлом
            ActiveWorkbook.Sheets(1).Select
            
        If Not IsEmpty(Range("A2")) Then
                FinalRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
                FinalColumn = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
                Sheets(1).Range(Sheets(1).Cells(2, 1), Sheets(1).Cells(FinalRow, FinalColumn)).Copy
        
            'Активация книги "..."
            Workbooks("....xlsm").Worksheets("...").Activate
            'Определение следующей пустой строки в файле "..."
            NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
            Rows(NextRow).Select
                    ActiveSheet.Paste
                    
            ' Активация листа"
            Worksheets("...").Activate
            'Определение следующей пустой строки в файле "..."
            NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
            Rows(NextRow).Select
                    ActiveSheet.Paste
                    Application.CutCopyMode = False
                    
            'Переход к активной книге сотрудников и удаление добавленных строк
            Workbooks(n).Activate
            ActiveWorkbook.Sheets(1).Select
            Sheets(1).Range(Sheets(1).Cells(2, 1), Sheets(1).Cells(FinalRow, FinalColumn)).Select
            Selection.Delete
            'Закрытие файлов сотрудников и сохранение
            ActiveWorkbook.Save
            ActiveWorkbook.Close
        
    Else: ActiveWorkbook.Close
 
    End If
    
End If
 
        sFiles = Dir
    Loop
    
'   Удаление записей по меткам
 
Workbooks("....xlsm").Worksheets("...").Activate
 
i = 1
 
    Do While Cells(i, 1) <> Empty
        If (Cells(i, 9).Value) Like "*новое время*" Or (Cells(i, 9).Value) Like "*последний перезвон*" Then
'            MsgBox Cells(i, 1).Value
            If (Cells(i, 9).Value) Like "*новое время*" Then a1 = Cells(i, 1).Value
            If (Cells(i, 9).Value) Like "*последний перезвон*" Then a2 = Cells(i, 1).Value
        End If
 
            b = 1
            Do While Cells(b, 1) <> Empty
 
                If (Cells(b, 1).Value) = a1 And Not (Cells(b, 9).Value) Like "*новое время*" And Not (Cells(b, 9).Value) Like "*последний перезвон*" Then
                    Rows(b).Delete
                    b = b - 1
                End If
                
                If (Cells(b, 1).Value) = a2 Then
                    Rows(b).Delete
                    b = b - 1
                End If
 
            b = b + 1
            Loop
 
    i = i + 1
    Loop
'
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True
 
    Workbooks("....xlsm").Close True 'Если поставить False - книга будет закрыта без сохранения
    
End Sub