Option Explicit
Sub consolidateReport()
Dim lr As Long
Dim ws As Worksheet
Dim i As Long
Dim report As Worksheet
Dim j As Long
Dim iSection As Long
Dim iSectionsProcessed As Long
Dim sSection As String
Dim sSheetName As String
Dim bSectionNumberEnabled As Boolean
Dim iValue As Long
Dim sValue As String
Application.ScreenUpdating = False
Set report = ThisWorkbook.Worksheets("Report") 'Name of output Sheet
Call RemoveOldDataAndMoveTotalsTableBeforeReport(report)
j = 1
For Each ws In Worksheets
sSheetName = Trim(ws.Name) 'Get the Sheet Name without leading and trailing spaces
If sSheetName <> "Report" Then
'Get the section number as a string
'Convert the section number to a number
'Process only Section Numbers 1 thru 7
sSection = Right(sSheetName, 1)
If IsNumeric(sSection) Then
iSection = CLng(sSection)
End If
If iSection >= 1 And iSection <= myNumberOfSectionLABELS Then
sValue = ActiveSheet.OLEObjects("Label" & iSection).Object.Caption
If UCase(sValue) = "X" Then
bSectionNumberEnabled = True
Else
bSectionNumberEnabled = False
End If
Else
bSectionNumberEnabled = False
End If
If bSectionNumberEnabled = True Then
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
If ws.Cells(i, 9) = "N" Or ws.Cells(i, 9) = "n" Or ws.Cells(i, 9) = "NO" Or ws.Cells(i, 9) = "no" Or ws.Cells(i, 9) = "No" Then
iSectionsProcessed = iSectionsProcessed + 1
If j = 1 Then ' if this is first entry in report
report.Range("A6") = 1
ws.Range("A" & i).Copy report.Range("B6") ' chnage 7 to first row number where you want data
ws.Range("G" & i).Copy report.Range("C6")
ws.Range("K" & i).Copy report.Range("D6")
ws.Range("P" & i).Copy report.Range("E6")
j = j + 1
Else ' further data will go below the 7 row with below code
report.Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1) = report.Range("A" & Cells(Rows.Count, 1).End(xlUp).Row) + 1
ws.Range("A" & i).Copy report.Range("B" & Cells(Rows.Count, 2).End(xlUp).Row).Offset(1, 0) ' here 2,3,4,5 is the column number where the data is pasted, say you want column A data to be pasted in column C than put 3.
ws.Range("G" & i).Copy report.Range("C" & Cells(Rows.Count, 3).End(xlUp).Row).Offset(1, 0)
ws.Range("K" & i).Copy report.Range("D" & Cells(Rows.Count, 4).End(xlUp).Row).Offset(1, 0)
ws.Range("P" & i).Copy report.Range("E" & Cells(Rows.Count, 5).End(xlUp).Row).Offset(1, 0)
End If
End If
Next i
End If
End If
Next
If iSectionsProcessed = 0 Then
GoTo MYEXIT
End If
report.Range("A6:I" & Cells(Rows.Count, 2).End(xlUp).Row).Select
' below code is formatting cells and putting boarder arounf it.
'The following line allows this module to run on Excel 2003
'The 'Selection.Interior' code will only be executed for Excel Versions Greater that 11.0 (Excel 2003 = 11.0)
If Application.Version > 11# Then
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
report.Range("A6:B" & Cells(Rows.Count, 2).End(xlUp).Row).Select
With Selection.Font
.Size = 16
End With
report.Range("E6:E" & Cells(Rows.Count, 2).End(xlUp).Row).Select
With Selection.Font
.Size = 16
End With
report.Range("C6:C" & Cells(Rows.Count, 2).End(xlUp).Row).Select
With Selection.Font
.Size = 16
End With
report.Range("D6:D" & Cells(Rows.Count, 2).End(xlUp).Row).Select
With Selection.Font
.Size = 16
End With
report.Range("F6:I" & Cells(Rows.Count, 2).End(xlUp).Row).Select
With Selection.Font
.Size = 16
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
report.Range("A6:I" & Cells(Rows.Count, 2).End(xlUp).Row).Borders.LineStyle = xlContinuous
report.Range("A6:A" & Cells(Rows.Count, 2).End(xlUp).Row).VerticalAlignment = xlCenter
report.Range("A6:A" & Cells(Rows.Count, 2).End(xlUp).Row).HorizontalAlignment = xlCenter
report.Range("A1").Select
MYEXIT:
Call DeleteUnusedRowsAfterReportIsGenerated(report)
Application.ScreenUpdating = True
End Sub
Sub RemoveOldDataAndMoveTotalsTableBeforeReport(report As Worksheet)
'This moves the 'Totals Table' to the Bottom of the SpreadSheet before the report is generated
'and then removes all OLD data
Dim r As Range
Dim iEndColumn As Long
Dim iEndRow As Long
Dim iStartColumn As Long
Dim iStartRow As Long
Dim sRange As String
'Find the cell in Column 'H' that contains the text 'Minors'
Set r = report.Range("H:H").Find(What:="Minors", _
After:=Range("H1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
'Do NOTHING if 'Minors' DOES NOT EXIST
'Otherwise MOVE the Table and Clear OLD Data
If Not r Is Nothing Then
'Set the value of NEED_TO_CLEAR_TABLE_DATA to 'True' to Clear the 4 cells containing data
'Set the value of NEED_TO_CLEAR_TABLE_DATA to 'False' to leave the current values (or formulas) in the 4 cells
#Const NEED_TO_CLEAR_TABLE_DATA = False
#If NEED_TO_CLEAR_TABLE_DATA = True Then
'Clear the contents of the 4 status items
'Starting one column to the right of the 'Minors' Cell
'and continuing down for the next 3 rows
r.Offset(0, 1) = ""
r.Offset(1, 1) = ""
r.Offset(2, 1) = ""
r.Offset(3, 1) = ""
#End If
'Create the range to be moved
'Height is 5 rows (current row and the next 4 rows down)
'Width is 3 columns (one to the left and one to the right of the found range)
iStartRow = r.Row
iEndRow = iStartRow + 4
iStartColumn = r.Column - 1
iEndColumn = iStartColumn + 2
'Move 'Totals Table' to the Bottom of the SpreadSheet
sRange = LjmExcelColumnNumberToChar(iStartColumn) & iStartRow & ":" & LjmExcelColumnNumberToChar(iEndColumn) & iEndRow
report.Range(sRange).Cut Destination:=Sheets("Report").Range("G10001")
Application.CutCopyMode = False
'Clear all the Rows after the Sheet Header and before the 'Totals Table'
report.Range("A6:I10000").Clear
End If
End Sub
Sub DeleteUnusedRowsAfterReportIsGenerated(report As Worksheet)
Dim r As Range
Dim iLastRowInColumnA As Long
Dim iFirstRowToDelete As Long
Dim iLastRowToDelete As Long
Dim iRow As Long
Dim sRange As String
'Find the Last Row used in Column 'A'
'The First ROW to DELETE is the row after the Last Row used in Column 'A'
'The first ROW to DELETE can NOT be LESS than ROW 6
iLastRowInColumnA = report.Range("A:A").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
iFirstRowToDelete = iLastRowInColumnA + 1
If iFirstRowToDelete < 6 Then
iFirstRowToDelete = 6
End If
'Find the cell in Column 'H' that contains the text 'Minors'
Set r = report.Range("H:H").Find(What:="Minors", _
After:=Range("H1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
'Do NOTHING if 'Minors' DOES NOT EXIST
'Otherwise DELETE all ROWS between the END OF DATA and the START OF THE TABLE
If Not r Is Nothing Then
'Get the Row before the row that contains the text 'Minors'
iRow = r.Row
iLastRowToDelete = iRow - 1
'Generate the Range of ROW to DELETE
sRange = iFirstRowToDelete & ":" & iLastRowToDelete
'Delete the rows
report.Rows(sRange).Delete
End If
End Sub
Public Function LjmExcelColumnNumberToChar(InputColumn As Long) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' This converts an Excel integer column number to "character column letter(s)"
' e.g. convert 1 to "A"
' e.g. convert 28 to "AB"
'
' This assumes 2 character column limitation of 702 columns = (26 * 27)
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If InputColumn > 26 Then
LjmExcelColumnNumberToChar = Chr(Int((InputColumn - 1) / 26) + 64) & Chr(((InputColumn - 1) Mod 26) + 65)
Else
LjmExcelColumnNumberToChar = Chr(InputColumn + 64)
End If
End Function
I can add code that either:
LinkBack URL
About LinkBacks
Darkprophecy 
Register To Reply
im such a happy bunny!!
its perfect!!!! this new file copys over the background colours and everything which is great. will be easy to use this going forward 
Bookmarks