Я рекомендую сделать копию вашей рабочей книги перед тестированием кода ниже.Не думаю, что я что-то сломал или что-то изменил, но кто знает.
- Всегда делайте ссылки на рабочие книги и рабочие листы явными.Это означает, что вы должны обращаться к ним по имени (или полному пути к файлу, если применимо).В противном случае все
cells / ranges будут относиться к любой рабочей книге и рабочему листу, которые будут активными (пока выполняется код). - Если вы собираетесь ссылаться на определенные рабочие листы по всему коду,сохраните их в начале переменной (затем обратитесь к переменной).
- Настоятельно рекомендуем поставить
Option Explicit перед вашим кодом.
В приведенном ниже коде предполагается, что interim иraw рабочие листы находятся в той же рабочей книге, в которой находится ваш код VBA.
Option Explicit
Sub DataSetTransformation()
' Assumes "raw" and "interim" sheets are in the same workbook that your VBA code is in.
With ThisWorkbook ' If this is not true, refer to the workbook by name.
Dim rawSheet As Worksheet
Set rawSheet = .Worksheets("raw")
Dim interimSheet As Worksheet
On Error Resume Next
Set interimSheet = .Worksheets("interim")
On Error GoTo 0
If Not (interimSheet Is Nothing) Then
Application.DisplayAlerts = False
interimSheet.Delete
Application.DisplayAlerts = True
End If
Set interimSheet = .Worksheets.Add(After:=rawSheet)
interimSheet.Name = "interim"
End With
Dim rowIndex As Long
Dim columnIndex As Long
With rawSheet
For rowIndex = .Cells.SpecialCells(xlLastCell).Row To 2 Step -1
For columnIndex = .Cells.SpecialCells(xlLastCell).Column To 1 Step -1
With .Cells(rowIndex, columnIndex)
If (.Font.FontStyle <> "Bold") And Not (.Font.FontStyle = "Regular" And Not IsEmpty(.Value2)) Then
.EntireRow.Delete
Exit For ' I think you want to exit the loop early here (to return to column 1).
End If
End With
Next columnIndex
Next rowIndex
End With
'Removing the extra space in the amount column
With rawSheet
.Range("B1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row).Replace What:=" ", Replacement:="", SearchOrder:=xlByColumns
.Rows("1:2").Delete Shift:=xlUp
'Converting count & sum columns to numbers
.Columns("B:B").TextToColumns Destination:=.Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Columns("D:D").TextToColumns Destination:=.Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Identifying the indent level
rowIndex = 2
Do While Trim(.Cells(rowIndex, "A")) <> ""
.Cells(rowIndex, "A").Offset(0, 4).Value = .Cells(rowIndex, "A").IndentLevel
rowIndex = rowIndex + 1
Loop
Dim cellFound As Range
Set cellFound = .Columns("A:A").Find("??????? ATLAS ????-???", LookIn:=xlValues)
With cellFound
' Always check if Range.Find found anything (even though I don't do this below); otherwise you will get an error when it didn't.
' Also, seems like you should be using Range.AutoFilter for this operation -- and copy-pasting all cells that are returned by the filter.
'Copying the Ylan-Yde data to a new sheet, pasting the Ylan-Yde data to the new sheet
.Range(cellFound, .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, cellFound.Column + 4)).Copy interimSheet.Range("A1")
End With
'Creating the column which says whether it is a main shop or Ylan-Yde
'Main shop
.Columns("A:A").Insert Shift:=xlToRight
.Range("B3").Copy .Range("A1")
.Range("A1").AutoFill Destination:=.Range("A1:A" & .Range("B" & .Rows.Count).End(xlUp).Row)
End With
'Ylan-Yde
With interimSheet
.Columns("A:A").Insert Shift:=xlToRight
.Range("B1").Copy .Range("A1")
.Range("A1").AutoFill Destination:=.Range("A1:A" & .Range("B" & Rows.Count).End(xlUp).Row)
End With
'Deleting the Ylan-Yde data from the Atlas data
With rawSheet
' Again, seems like you should be using Range.AutoFilter for this.
Set cellFound = .Columns("B:B").Find("??????? ATLAS ????-???", LookIn:=xlValues)
.Rows(cellFound.Row & ":" & .Rows.Count).Delete
End With
'Deleting the total sum row
With interimSheet
.Cells(.Rows.Count, "A").End(xlUp).EntireRow.Delete
End With
'Calculating the % contribution to total - main shop sheet
With rawSheet
.Range("G3:G" & .Range("A" & .Rows.Count).End(xlUp).Row).FormulaR1C1 = "=RC[-2]/R3C5"
.Columns("G").Value2 = .Columns("G").Value2
End With
'Calculating the % contribution to total - Ylan-Yde sheet
With interimSheet
.Range("G1:G" & .Range("A" & .Rows.Count).End(xlUp).Row).FormulaR1C1 = "=RC[-2]/R1C5"
.Columns("G").Value2 = .Columns("G").Value2
Dim lastRw As Long
'Copying the Yland-Yde data back to the main shop data
.Range("A1:G" & Cells(.Rows.Count, "A").End(xlUp).Row).Copy
End With
With rawSheet
.Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, "A").PasteSpecial xlPasteAll
'Naming the newly created cols
.Range("A1").Value = "M"
.Range("A2").Value = ""
.Range("F1").Value = "L"
.Range("F2").Value = ""
.Range("G1").Value = "%"
.Range("G2").Value = ""
.Range("B1").Copy
.Range("A1:A2").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.Range("B1").Copy
.Range("F1:G2").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Changing the format of the % contribution to %
With .Columns("G:G")
.Style = "Percent"
.NumberFormat = "0.00%"
End With
'Adding the blue background
With .Range("G1", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, "F"))
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 16777200
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
'Adding the table borders
Dim bordersToChange As Variant
bordersToChange = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)
' You repeat yourself a lot when applying border styles. Maybe something like the below is effectively the same, but easier to maintain.
For rowIndex = LBound(bordersToChange) To UBound(bordersToChange)
With .Borders(bordersToChange(rowIndex))
.LineStyle = xlContinuous
.ThemeColor = 9
.TintAndShade = 0
.Weight = xlThin
End With
Next rowIndex
End With
End With
'Deleting the interim sheet
Application.DisplayAlerts = False
interimSheet.Delete
Application.DisplayAlerts = True
MsgBox "Whoop, whoop, that's all folks!"
End Sub
Как правило, большие / длинные процедуры лучше разбить на меньшие / короткие процедуры.