Thread: de-consolidate procedure into parts

Hi All, I'm facing problem in deconsolidate procedure. below is the code, can anybody help on this.

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim MainFile As String
Dim GlbFile As String
Dim RegFCell As Integer
Dim RegFName As String
Dim RegCell As Integer
Dim RegName As String
Dim SheetCell As Integer
Dim SheetName As String
Dim MyCell As String
GlbFile = ActiveWorkbook.Name
Workbooks(GlbFile).Activate
RegFCell = 6
RegFName = ActiveWorkbook.Sheets("Screener Process").Range("C" & RegFCell).Value
RegCell = 6
RegName = ActiveWorkbook.Sheets("Screener Process").Range("G" & RegCell).Value
Do
ActiveWorkbook.Sheets.Copy
SheetCell = 8
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E" & SheetCell).Value
Do
Sheets(SheetName).Select
If Range("A2").Value <> "" Then
Selection.AutoFilter Field:=1, Criteria1:="<>" & RegName
Rows(2).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Selection.AutoFilter
End If
SheetCell = SheetCell + 1
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E" & SheetCell).Value
Loop While SheetName <> ""
Sheets("Index").Select
Rows(2).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Range("A1").Select
SheetCell = 8
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E8").Value
Do
ActiveWorkbook.Sheets(SheetName).Select
With ActiveSheet.Columns(9)
If Range("I2").Value <> "" Then
Range("I2", Range("I1000000").End(xlUp).Address).Copy
ActiveSheet.Paste Destination:=Worksheets("Index").Range("A100000").End(xlUp).Offset(1, 0)
End If
SheetCell = SheetCell + 1
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E" & SheetCell).Value
End With
Loop While SheetName <> ""
Sheets("Index").Select
Columns("A:A").Select
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:= _
xlYes
ActiveWorkbook.Worksheets("Index").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Index").Sort.SortFields.Add Key:=Range("A:A") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Index").Sort
.SetRange Range("A:A")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
SheetCell = 8
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E8").Value
Do
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = SheetName
ActiveCell.Offset(1, 0).Value = "=COUNTIF('" & SheetName & "'!I:I,$A2)"
SheetCell = SheetCell + 1
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E" & SheetCell).Value
Loop While SheetName <> ""

ActiveCell.Offset(0, 1).Value = "Total"
ActiveCell.Offset(1, 1).Value = "=Sum(B2:" & ActiveCell.Offset(1, 0).Address(False, False) & ")"
ActiveCell.Offset(1, 1).Select
Range(Selection, Range("A1").End(xlDown).Offset(0, 1)).Select
Selection.FillDown
Range("A1").End(xlDown).Offset(1, 0).Select
ActiveCell.Value = "Total"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "=Sum(B2:" & Range("A1").End(xlDown).Offset(-1, 1).Address(False, False) & ")"
ActiveCell.Offset(-1, 0).Select
ActiveCell.End(xlToRight).Offset(1, 0).Select
Range(Selection, ActiveCell.End(xlToLeft).Address(False, False)).Select
Selection.FillRight
Range("A1", Range("A1").End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

With Selection
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders.ColorIndex = xlAutomatic
.Font.Name = "Palatino Linotype"
.Font.Size = 9
.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
.Columns.AutoFit
End With
Range("A1").Select

ActiveWorkbook.Sheets.Add
ActiveSheet.Name = "Stats"
Range("A1").Value = "Team leader"

SheetCell = 8
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E8").Value

Do
ActiveWorkbook.Sheets(SheetName).Select
With ActiveSheet.Columns(3)
If Range("I2").Value <> "" Then
Range("C2", Range("C1000000").End(xlUp).Address).Copy
ActiveSheet.Paste Destination:=Worksheets("Stats").Range("A100000").End(xlUp).Offset(1, 0)
End If
SheetCell = SheetCell + 1
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E" & SheetCell).Value
End With
Loop While SheetName <> ""

Sheets("Stats").Select
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes

Sheets("Screener Process").Select
Range("E8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Stats").Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False
Range("A1").End(xlDown).Offset(1, 0).Value = "Total"
Range("A1").End(xlToRight).Offset(0, 1).Value = "Total"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders.ColorIndex = xlAutomatic
.Font.Name = "Palatino Linotype"
.Font.Size = 9
.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
.Columns.AutoFit
End With
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Font.Bold = True
Selection.Interior.ColorIndex = 6


Range("A1").Select
SheetCell = 8
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E8").Value

Do
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(1, 0).Value = "=COUNTIF('" & SheetName & "'!C:C,$A2)"
SheetCell = SheetCell + 1
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E" & SheetCell).Value
Loop While SheetName <> ""

ActiveCell.Offset(1, 1).Value = "=Sum(B2:" & ActiveCell.Offset(1, 0).Address(False, False) & ")"
ActiveCell.Offset(1, 1).Select
Range(Selection, Range("A1").End(xlDown).Offset(-1, 1)).Select
Selection.FillDown
Range("A1").End(xlDown).Offset(0, 1).Select
ActiveCell.Value = "=Sum(B2:" & Range("A1").End(xlDown).Offset(-1, 1).Address(False, False) & ")"
ActiveCell.Offset(-1, 0).Select
ActiveCell.End(xlToRight).Offset(1, 0).Select
Range(Selection, ActiveCell.End(xlToLeft).Address(False, False)).Select
Selection.FillRight
Range("A1", Range("A1").End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False


Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("A1").End(xlDown).Offset(3, 0).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
MyCell = ActiveCell.Address(False, False)
Range(MyCell).Offset(-1, 0).Value = "Fixed Exceptions"

Range("A1", Range("A1").End(xlDown)).Copy
ActiveSheet.Paste Destination:=Range(MyCell)
Application.CutCopyMode = False
Range("A1", Range("A1").End(xlToRight)).Copy
ActiveSheet.Paste Destination:=Range(MyCell)
Application.CutCopyMode = False

SheetCell = 8
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E8").Value
Range(MyCell).Offset(1, 0).Select
Do
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "=COUNTIFS('" & SheetName & "'!C:C," & Range(MyCell).Offset(1, 0).Address(False, False) & ",'" & SheetName & "'!F:F,""<>""&"""")"
SheetCell = SheetCell + 1
SheetName = ActiveWorkbook.Sheets("Screener Process").Range("E" & SheetCell).Value
Loop While SheetName <> ""

ActiveCell.Offset(0, 1).Value = "=SUM(" & Range(MyCell).Offset(1, 1).Address(False, False) & ":" & ActiveCell.Address(False, False) & ")"
Range(MyCell).Offset(1, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Range(MyCell).End(xlDown).Offset(-1, 1)).Select
Selection.FillDown
Range(MyCell).End(xlDown).Offset(0, 1).Select
ActiveCell.Value = "=SUM(" & Range(MyCell).Offset(1, 1).Address(False, False) & ":" & ActiveCell.Offset(-1, 0).Address(False, False) & ")"

ActiveCell.Offset(-1, 0).Select
ActiveCell.End(xlToRight).Offset(1, 0).Select
Range(Selection, ActiveCell.End(xlToLeft).Address(False, False)).Select
Selection.FillRight
Range(MyCell, Range(MyCell).Offset(0, 1)).Select
Selection.Copy
Range(MyCell).Offset(-1, 0).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

next part is:
Range("A1:" & Range("A1").End(xlToRight).Address).Select
Range(Selection, Selection.End(xlDown)).Copy
ActiveSheet.Paste Destination:=Range(MyCell).End(xlDown).Offset(3, 0)

Range(MyCell).End(xlDown).Offset(4, 1).Select
ActiveCell.Value = "=" & Range("B2").Address(False, False) & "-" & Range(MyCell).Offset(1, 1).Address(False, False)
Range(Selection, Selection.End(xlToRight)).Select
Selection.FillRight
Range(Selection, Selection.End(xlDown)).FillDown

Range(Range(MyCell).Offset(-1, 0).Address & ":" & Range(MyCell).Offset(-1, 1).Address).Copy
ActiveSheet.Paste Destination:=Range(MyCell).End(xlDown).Offset(2, 0)
Range(MyCell).End(xlDown).Offset(2, 0).Value = "Pending Exceptions"
Application.CutCopyMode = False
Sheets("Screener Process").Delete
Sheets("Stats").Select
Range("A1").Select

On Error Resume Next
MkDir "C:\" & MonthName(Month(Now)) & "-Screeners"

ActiveWorkbook.SaveAs Filename:="C:\" & MonthName(Month(Now)) & "-Screeners\" & RegFName & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Workbooks(GlbFile).Activate

RegFCell = RegFCell + 1
RegFName = ActiveWorkbook.Sheets("Screener Process").Range("C" & RegFCell).Value

RegCell = RegCell + 1
RegName = ActiveWorkbook.Sheets("Screener Process").Range("G" & RegCell).Value

Loop While RegName <> ""

Application.ScreenUpdating = False
Application.DisplayAlerts = False


End Sub

Hi sidduk83

It a big chuck of code.. what do you want to know?