Option Explicit
Sub Preobrazovanie()
Dim Str&, a&, Aws$, b%, d%, e%
Dim L As Worksheet
Dim Sh As Worksheet
Dim c As Boolean
Application.ScreenUpdating = False
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name = "Обработанная" Then
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
End If
Next Sh
Aws = ActiveSheet.Name
Str = Worksheets(Aws).UsedRange.Row + Worksheets(Aws).UsedRange.Rows.Count - 1
Set L = Worksheets.Add(After:=ActiveSheet)
L.Name = "Обработанная"
b = 2
For a = 1 To Str
If InStr(1, Worksheets(Aws).Cells(a, 2), "Кор.") Or _
InStr(1, Worksheets(Aws).Cells(a, 2), "сальдо") Or _
InStr(1, Worksheets(Aws).Cells(a, 2), "Оборот") Or _
Worksheets(Aws).Cells(a, 2) = "" Then
Else
b = b + 1
L.Cells(b, 1) = Worksheets(Aws).Cells(a, 2)
End If
Next a
L.Range("A3:A" & b).RemoveDuplicates Columns:=1, Header:=xlNo
e = L.UsedRange.Row + L.UsedRange.Rows.Count - 1
b = -1
For a = 1 To Str
If Worksheets(Aws).Cells(a, 1) <> "" And _
Worksheets(Aws).Cells(a + 1, 1) <> "" And _
Worksheets(Aws).Cells(a, 2) = "Начальное сальдо" And _
Worksheets(Aws).Cells(a + 1, 2) = "Начальное сальдо" And _
(Worksheets(Aws).Cells(a + 2, 3) <> "" Or Worksheets(Aws).Cells(a + 2, 4) <> "") Then
b = b + 3
L.Cells(1, b) = Worksheets(Aws).Cells(a, 1)
L.Cells(2, b) = Worksheets(Aws).Cells(a + 1, 1)
L.Cells(1, b + 1) = "Дебет"
L.Cells(1, b + 2) = "Кредит"
L.Columns(b + 1).NumberFormat = "#,##0.00"
L.Columns(b + 2).NumberFormat = "#,##0.00"
L.Columns(1).HorizontalAlignment = xlLeft
L.Range(Cells(3, b + 1), Cells(e, b + 2)).Interior.Color = RGB(228, 223, 236)
a = a + 1
Else
If b <> -1 Then
If InStr(1, Worksheets(Aws).Cells(a, 2), "Кор.") Or _
InStr(1, Worksheets(Aws).Cells(a, 2), "сальдо") Or _
InStr(1, Worksheets(Aws).Cells(a, 2), "Оборот") Or _
Worksheets(Aws).Cells(a, 2) = "" Then
Else
For d = 3 To e
If L.Cells(d, 1) = Worksheets(Aws).Cells(a, 2) Then
L.Cells(d, b + 1) = Worksheets(Aws).Cells(a, 3)
L.Cells(d, b + 2) = Worksheets(Aws).Cells(a, 4)
End If
Next d
End If
End If
End If
Next a
L.Range(Cells(1, 1), Cells(2, b + 2)).Interior.Color = RGB(238, 236, 225)
L.Range(Cells(1, 1), Cells(2, b + 2)).HorizontalAlignment = xlCenter
L.UsedRange.Borders.LineStyle = xlContinuous
L.UsedRange.Columns.AutoFit
L.Activate
L.Cells(3, 2).Select
ActiveWindow.FreezePanes = True
Application.ScreenUpdating = True
MsgBox "Выполнено", vbInformation, "Отчёт о выполнении"
End Sub
|