Структура макроса

[1134]

Вот он проблемный файл --> макрос Табличка

[SAS888]

В макрос "TABLICHKA1" внес изменения, которые я советовал Вам сделать в посте №8. Ошибка исчезла. Посмотрите вложение.

[1134]

Sub TABLICHKA1()

Dim ws As Worksheet, x As Range, y As Range, i As Long, fst As String, nm As Integer
Application.ScreenUpdating = False: Application.DisplayAlerts = False
On Error Resume Next: Sheets("Èñòîðè÷åñêèå ïîêàçàòåëè").Delete: On Error GoTo 0
Worksheets.Add.Name = "Èñòîðè÷åñêèå ïîêàçàòåëè"
[A1] = "--WELL": [B1] = "DD.MM.YYYY": [C1] = "Qoil,ì3/ñóò"
[D1] = "Qwat,ì3/ñóò": [E1] = "Qliq,ì3/ñóò": [F1] = "WEFA": [G1] = "BHP"
For Each ws In Sheets
If ws.Name <> ActiveSheet.Name Then
Set x = ws.[D:D].Find(what:="Qæ,ì3/ñóò", LookAt:=xlWhole)
If Not x Is Nothing Then
fst = x.Address
Do
i = Cells(Rows.Count, 1).End(xlUp).Row + 1: Cells(i, 1) = ws.Name
Cells(i, 2) = DateValue(ws.Cells(x.Row, 1) & " 1, 2009") 'Year(Date))
Cells(i, 5) = Application.AverageIf(ws.Range(ws.C ells(x.Row, 6), ws.Cells(x.Row, 36)), "<>0")
If Application.IsErr(Cells(i, 5)) Then Range(Cells(i, 3), Cells(i, 7)) = 0
If ws.[AC5] <> "" Then Cells(i, 7) = ws.[AC5]
If Cells(i, 6).Value <> "0" Then
nm = Day(DateSerial(Year(Cells(i, 2)), Month(Cells(i, 2)) + 1, 1) - 1)
Cells(i, 6) = Application.CountA(ws.Range(ws.Cell s(x.Row, 6), ws.Cells(x.Row, 36))) / nm
End If
If Cells(i, 5) <> 0 And Val(ws.[AG5]) <> 0 Then _
Cells(i, 3) = Application.AverageIf(ws.Range(ws.C ells(x.Row + 1, 6), ws.Cells(x.Row + 1, 36)), "<>0") / ws.[AG5] _
Else Cells(i, 3) = 0
Set x = ws.[D:D].FindNext(x)
Loop While fst <> x.Address
End If: End If: Next: Columns("A:G").AutoFit

End Sub

Но у меня по-прежнему затыкается на листе 1033 и по-прежнему выдаёт ошибку в той же строке...

[1134]

Sub TABLICHKA1()

Dim ws As Worksheet, x As Range, y As Range, i As Long, fst As String, nm As Integer
Application.ScreenUpdating = False: Application.DisplayAlerts = False
On Error Resume Next: Sheets("Èñòîðè÷åñêèå ïîêàçàòåëè").Delete: On Error GoTo 0
Worksheets.Add.Name = "Èñòîðè÷åñêèå ïîêàçàòåëè"
[A1] = "--WELL": [B1] = "DD.MM.YYYY": [C1] = "Qoil,ì3/ñóò"
[D1] = "Qwat,ì3/ñóò": [E1] = "Qliq,ì3/ñóò": [F1] = "WEFA": [G1] = "BHP"
For Each ws In Sheets
If ws.Name <> ActiveSheet.Name Then
Set x = ws.[D:D].Find(what:="Qæ,ì3/ñóò", LookAt:=xlWhole)
If Not x Is Nothing Then
fst = x.Address
Do
i = Cells(Rows.Count, 1).End(xlUp).Row + 1: Cells(i, 1) = ws.Name
Cells(i, 2) = DateValue(ws.Cells(x.Row, 1) & " 1, 2009") 'Year(Date))
Cells(i, 5) = Application.AverageIf(ws.Range(ws.C ells(x.Row, 6), ws.Cells(x.Row, 36)), "<>0")
If Application.IsErr(Cells(i, 5)) Then Range(Cells(i, 3), Cells(i, 7)) = 0
If ws.[AC5] <> "" Then Cells(i, 7) = ws.[AC5]
If Cells(i, 6).Value <> "0" Then
nm = Day(DateSerial(Year(Cells(i, 2)), Month(Cells(i, 2)) + 1, 1) - 1)
Cells(i, 6) = Application.CountA(ws.Range(ws.Cell s(x.Row, 6), ws.Cells(x.Row, 36))) / nm
End If
If Cells(i, 5) <> "0" And ws.[AG5] <> "" Then
If Application.IsErr(Application.Avera geIf(ws.Range(ws.Cells(x.Row + 1, 6), ws.Cells(x.Row + 1, 36)), "<>0")) Then
Cells(i, 3).Value = 0
Else:
Cells(i, 3).Value = Application.AverageIf(ws.Range(ws.C ells(x.Row + 1, 6), ws.Cells(x.Row + 1, 36)), "<>0") / ws.[AG5]
End If
End If
If Cells(i, 3) <> 0 And Cells(i, 5) <> 0 And Cells(i, 3) <> "" And Cells(i, 5) <> "" Then _
Cells(i, 4).Value = Cells(i, 5).Value - Cells(i, 3).Value
If Cells(i, 3) = 0 Or Cells(i, 3) = "" And Cells(i, 4) = 0 Then
Cells(i, 4) = Cells(i, 5): Cells(i, 5) = 0: Cells(i, 3) = 0
End If
Set x = ws.[D:D].FindNext(x)

Loop While fst <> x.Address
End If: End If: Next: Columns("A:G").AutoFit

Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub

Вот так заработало + я ещё кое что добавил.
Подскажите пожалуйста как мне можно сместить дату на 1 месяц вперёд?

[SAS888]

Подскажите пожалуйста как мне можно сместить дату на 1 месяц вперёд?

Какую дату? В каком месте? Не экономьте слова, объясните подробнее.

[1134]

Во втором столбце таблички у меня выгружает:

01.01.2009
01.02.2009
01.03.2009
01.04.2009
01.05.2009
01.06.2009
01.07.2009
01.08.2009
01.09.2009
01.10.2009
01.11.2009
01.12.2009

а хочется так:

01.02.2009
01.03.2009
01.04.2009
01.05.2009
01.06.2009
01.07.2009
01.08.2009
01.09.2009
01.10.2009
01.11.2009
01.12.2009
01.01.2010

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

[SAS888]

Если речь идет о данных столбца "B" в сформированном макросом листе "Исторические показатели", то в самом конце кода макроса "TABLICHKA1" добавьте следующий код:

Dim cell As Range: Application.ScreenUpdating = False
For Each cell In Range([B2], Cells(Rows.Count, 2).End(xlUp))
    cell = DateSerial(Year(cell), Month(cell) + 1, Day(cell))
Next

[1134]

Спасибо ещё раз!