An exception occurred as described below source tmacv6 error 9 subscript out of range

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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161

Sub Statistika()
 SearchingPath = Application.GetOpenFilename("Ôàéëû Microsoft Office Excel (*.xls), *.xls", _
 Title:="Ïîèñê ôàéëîâ äëÿ áàçû äàííûõ (Car*.xls)")
 
 'Ìåõàíèçì âûäåëåíèÿ ïóòè ê ïàïêå èç ïîëíîãî ïóòè ê ôàéëó
 k = InStr(1, StrReverse(SearchingPath), "")
 SearchingPath = Left(SearchingPath, Len(SearchingPath) - k + 1)
 
 Application.ScreenUpdating = False
 
 'Íîâûé ñïîñîá çàäàíèÿ ïàïêè ñ ôàéëàìè
 'With Application.FileDialog(msoFileDialogFolderPicker)
 '    .Show
 '    SearchingPath = .SelectedItems(1)
 'End With
 
 Set DataCell = Workbooks("statistika").Sheets("Ñóììû").Range("A1")
 With Application.FileSearch
   .LookIn = SearchingPath
   '.Filename = SearchingPath
   .Filename = "Car*.xls"
   .Execute
   NumOfFiles = .Execute
   For i = 1 To .FoundFiles.Count
  'ïðîâåðêà íàõîæäåíèÿ îáðàáîòàííîãî ôàéëà â áàçå äàííûõ
    Do
     
     'ìåõàíèçì âûäåëåíèÿ íàçâàíèÿ ôàéëà èç ïîëíîãî ïóòè ê íåìó
     FullName = .FoundFiles(i)
     k = InStr(1, StrReverse(FullName), "")
     Path = Left(FullName, Len(FullName) - k + 1)
     Filename = Right(FullName, k - 1)
     
     
     'DataCell.Range("I2").FormulaR1C1 = _
      '  "=MID(R[0]C[-1],4,2)&"".""&MID(R[0]C[-1],6,2)&"".99"""
     'DataCell.Range("G1").Copy
     Set NameCell = Workbooks("statistika").Sheets("Ñóììû").Range("C9900")
     Do
      Set NameCell = NameCell.Offset(1, 0)
      s = NameCell.Address
      d = NameCell.Value
      If NameCell.Value = Filename Then
        'MsgBox ("Ôàéë " & FileName & " óæå îáðàáàòûâàëñÿ")
        i = i + 1
      End If
     Loop Until IsEmpty(NameCell.Offset(0, -1)) Or (NameCell.Value = Filename)
    Loop Until IsEmpty(NameCell.Offset(0, -1)) Or i > .FoundFiles.Count
    
    If Not (i > .FoundFiles.Count) Then
     Workbooks.Open (.FoundFiles(i))
     'Sheets("Car").Activate
     Set CarCell = Sheets("Car").Range("A1")
    'Íàõîæäåíèå ïåðâîé ïóñòîé ÿ÷åéêè â òàáëèöå
     Set DataCell = Workbooks("statistika").Sheets("Ñóììû").Range("A1")
     Do
       Set DataCell = DataCell.Offset(1, 0)
     Loop Until IsEmpty(DataCell.Range("B1")) And IsEmpty(DataCell.Range("C1"))
     
     s = DataCell.Address
     With DataCell
     'Ïåðåíîñ "øàïêè" (îáùèõ äàííûõ) â áàçó
        .Range("C1").Value = Filename
        .Range("B1").FormulaR1C1 = _
        "=MID(R[0]C[1],4,2)&"".""&MID(R[0]C[1],6,2)&"".07"""
        .Range("G1").Copy
        
        
     'ñôîðìèðîâàííàÿ ñòðîêà ÿâëÿåòñÿ øàáëîíîì îáùèõ äàííûõ. Îíà óäàëÿåòñÿ
        Set ShablonRow = _
         Workbooks("statistika").Sheets("Ñóììû").Range(DataCell.Row & ":" & DataCell.Row)
     'Ïåðåíîñ äàííûõ î òîâàðå â áàçó
        Set CarCell = Workbooks(Filename).Sheets("Car").Range("A1")
        
        Do
         If Not (CarCell.Column > 20) Then
           Set CarCell = CarCell.Offset(0, 1)
         Else
           Set CarCell = CarCell.Offset(1, -20)
         End If
        Loop Until (CarCell.Value = "òîâàð") Or (CarCell.Row > 50)
        
       If Not (CarCell.Value = "òîâàð") Then
        MsgBox ("ÿ÷åéêè ñî çíà÷åíèåì ""òîâàð"" â ôàéëå " & Filename & " íåò")
       Else
        Set BegCell = CarCell
        s = CarCell.Address
        
        Do
         If Not (CarCell.Column > 20) Then
            Set CarCell = CarCell.Offset(0, 1)
         Else
            Set CarCell = CarCell.Offset(1, -20)
         End If
         If IsEmpty(CarCell) Then
          n = n + 1
         Else
          n = 0
         End If
         s = CarCell.Address
        Loop Until (CarCell.Value = "Âñåãî:") Or (n > 20 * 20)
        
       If Not (CarCell.Value = "Âñåãî:") Then
        MsgBox ("ÿ÷åéêè ñî çíà÷åíèåì ""Âñåãî:"" â ôàéëå " & Filename & " íåò")
       Else
        Set EndCell = CarCell
        s = EndCell.Address
        Set CarCell = Workbooks(Filename).Sheets("Car").Range("A1")
        Set CarCell = BegCell.Offset(1, -1) 'ñòðîêà ïîñëå BegCell, ñòîëáåö À
        Do
         With CarCell
         'ïîñòàâùèê
          s = CarCell.Address
          If Not IsEmpty(.Range("B1")) And ((.Range("B1").Font.ColorIndex = 3) Or _
          (.Range("B1").Font.ColorIndex = 10) Or (.Range("B1").Font.ColorIndex = 43)) And _
          IsEmpty(.Range("A1")) Then
           vFirma = .Range("B1").Value
           Set CarCell = CarCell.Offset(1, 0)
           s = CarCell.Address
           bool = False
           Do
            With CarCell
             If Not IsEmpty(.Range("H1")) And ((.Range("H1").Font.ColorIndex = 3) Or _
              (.Range("H1").Font.ColorIndex = 10) Or (.Range("H1").Font.ColorIndex = 43)) _
              And IsEmpty(.Range("A1")) Then
               vSumma = .Range("H1").Value
               Set DataCell = DataCell.Offset(1, 0)
               ShablonRow.Copy
               DataCell.Range("1:1").PasteSpecial
               DataCell.Range("F1").Value = vSumma
               DataCell.Range("G1").Value = vFirma
               bool = True
               Set CarCell = CarCell.Offset(-2, 0)
               s = CarCell.Address
             End If
             Set CarCell = CarCell.Offset(1, 0)
             s = CarCell.Address
            End With
           Loop Until bool
          End If
          Set CarCell = CarCell.Offset(1, 0)
          s = CarCell.Address
         End With
        Loop Until CarCell.Row = EndCell.Row - 1
       End If 'âñåãî:
       End If 'òîâàð
     End With
     ShablonRow.Delete shift:=xlUp
     .Filename = .FoundFiles(i)
     Workbooks(Filename).Close SaveChanges:=False
     'MsgBox ("Çàêîí÷åíà îáðàáîòêà ôàéëà " & .FileName)
     'Workbooks("statistika").Save
    End If ' not(i > .FoundFiles.Count)
   Next i
   'MsgBox ("Îáðàáîòêà äàííûõ çàêîí÷åíà")
   Application.ScreenUpdating = True
 End With
 
 
 
End Sub