Hi guys,
I have a piece of code that consolidates data onto one sheet.
Once the code has copied everything over, I would like it to also duplicate the Category field.
Please be advised that there is no option to add the duplicated column in the source information.
Here is the consolidation code:
Sub Consolidate()
'
Dim wsTest As Worksheet
'check if sheet "Consolidated" already exist
Const strSheetName As String = "Consolidated"
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.Name = strSheetName
End If
With Sheets("Consolidated")
.UsedRange.ClearContents
.Range("A1:M1").Value = Array("Category", "Work Type", "Activity Description", "Related Service", "Priority Theme", "SI Owner", "SI Role", "Problem Statement", "Deliverables", "Progress", "Status", "Target Date", " RAG")
'Work Item Service Related Priority SI Owner SI Role Objectives Status Target Date RAG
' change the names of the columns
For Each sh In Sheets
With sh
If .Name <> "Consolidated" And .Name <> "Completed" And .Name <> "Not Progressed" And .Name <> "AddRecord" And .Name <> "Home Page" Then
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
If LR >= 28 Then
Rng = .Cells.Find("*", , , , xlByRows, xlPrevious).Row - 1
NR = Sheets("Consolidated").Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
If Rng > 0 Then
Sheets("Consolidated").Cells(NR, 1).Resize(Rng) = .Name
Sheets("Consolidated").Cells(NR, 2).Resize(Rng, 13) = .Range("A28").Resize(Rng, 13).Value
End If
End If
End If
End With
Next
On Error Resume Next
.Range("B2:B" & .Rows.Count).SpecialCells(4).EntireRow.Delete
.Columns("A:Z").EntireColumn.AutoFit
End With
Sheets("Report").Select
Range("A1").Select
End Sub
Bookmarks