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