Option Explicit
Const m_strSOURCE_SHEET = "P - Paste" ' <-- Set name of source sheet here
Const m_strOUTPUT_SHEET = "F - Front" ' <-- Set name of output sheet here
' ------------------------------------------------------------------------------
Private Enum enmPaperInfo
enmPaperInfoCode
enmPaperInfoTemplate
End Enum
' ------------------------------------------------------------------------------
Sub CreateSummary()
' ++++++++++++++++++++++++++
' +++ RUN THIS PROCEDURE +++
' ++++++++++++++++++++++++++
Dim lngPaperCount As Long
Dim astrHeaders() As String
Dim lngTourCount As Long
Dim lngMaxTours As Long
Dim avntData() As Variant
Dim clnPapers As Collection
Dim wksOutput As Worksheet
Dim clnTours As Collection
Dim strPaper As String
Dim j As Long
Dim k As Long
On Error Resume Next
Set wksOutput = ThisWorkbook.Sheets(m_strOUTPUT_SHEET)
On Error GoTo ErrorHandler
If wksOutput Is Nothing Then
Set wksOutput = ThisWorkbook.Sheets.Add
wksOutput.Name = m_strOUTPUT_SHEET
Else
wksOutput.UsedRange.Clear
End If
Set clnPapers = GetAllPapers()
lngPaperCount = clnPapers.Count
For j = 1 To lngPaperCount
strPaper = clnPapers(j)
Set clnTours = GetTours(strPaper)
lngTourCount = clnTours.Count
If lngMaxTours < lngTourCount Then lngMaxTours = lngTourCount
ReDim Preserve avntData(1 To lngPaperCount, 1 To lngMaxTours + 3)
avntData(j, 1) = strPaper
avntData(j, 2) = GetPaperInfo(strPaper, enmPaperInfoTemplate)
avntData(j, 3) = GetPaperInfo(strPaper, enmPaperInfoCode)
For k = 1 To lngTourCount
avntData(j, k + 3) = clnTours(k)
Next k
Next j
ReDim astrHeaders(1 To lngMaxTours + 3)
astrHeaders(1) = "Paper"
astrHeaders(2) = "Template"
astrHeaders(3) = "Code"
For k = 1 To lngMaxTours
astrHeaders(k + 3) = "Tour " & k
Next k
With wksOutput.Range("A1").Resize(, lngMaxTours + 3)
.Value = astrHeaders
.Font.Bold = True
End With
If lngPaperCount > 0 Then
With wksOutput.Range("A2")
.Resize(lngPaperCount, lngMaxTours + 3).Value = avntData
.CurrentRegion.EntireColumn.AutoFit
End With
End If
wksOutput.Activate
MsgBox "Summary created for " & lngPaperCount & " paper(s).", vbInformation
ExitHandler:
Set clnPapers = Nothing
Set clnTours = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
' ------------------------------------------------------------------------------
Private Function GetAllPapers() As Collection
Dim intSourceCol As Integer
Dim clnPapers As New Collection
Dim strPaper As String
Dim j As Long
On Error GoTo ErrorHandler
With ThisWorkbook.Sheets(m_strSOURCE_SHEET)
intSourceCol = .Rows(1).Find("Paper Name", , xlValues, xlWhole).Column
For j = 2 To .Cells(.Rows.Count, intSourceCol).End(xlUp).Row
strPaper = .Cells(j, intSourceCol).Text
If Len(strPaper) > 0 Then
On Error Resume Next
clnPapers.Add strPaper, strPaper
On Error GoTo ErrorHandler
End If
Next j
Set GetAllPapers = clnPapers
End With
ExitHandler:
Set clnPapers = Nothing
Exit Function
ErrorHandler:
Set GetAllPapers = New Collection
Resume ExitHandler
End Function
' ------------------------------------------------------------------------------
Private Function GetPaperInfo(strPaper As String, PaperInfo As enmPaperInfo)
Dim strTargetName As String
Dim intSourceCol As Integer
Dim intTargetCol As Integer
Dim rngPapers As Range
Dim rngPaper As Range
On Error GoTo ErrorHandler
With ThisWorkbook.Sheets(m_strSOURCE_SHEET)
intSourceCol = .Rows(1).Find("Paper Name", , xlValues, xlWhole).Column
Set rngPapers = Intersect(.Columns(intSourceCol), .UsedRange)
Set rngPaper = rngPapers.Find(strPaper, , xlValues, xlWhole)
If rngPaper Is Nothing Then
GetPaperInfo = Empty
Exit Function
Else
Select Case PaperInfo
Case enmPaperInfoCode
strTargetName = "Code"
Case enmPaperInfoTemplate
strTargetName = "Template Size"
Case Else
Err.Raise 513, "GetPaperInfo", "Argument out of range"
End Select
intTargetCol = .Rows(1).Find(strTargetName, , xlValues, xlWhole).Column
GetPaperInfo = .Cells(rngPaper.Row, intTargetCol).Text
End If
End With
Exit Function
ErrorHandler:
GetPaperInfo = Empty
End Function
' ------------------------------------------------------------------------------
Private Function GetTours(strPaper As String) As Collection
Dim intSourceCol As Integer
Dim intTargetCol As Integer
Dim clnTours As New Collection
Dim strAddress As String
Dim rngPapers As Range
Dim rngPaper As Range
Dim strTour As String
On Error GoTo ErrorHandler
With ThisWorkbook.Sheets(m_strSOURCE_SHEET)
intSourceCol = .Rows(1).Find("Paper Name", , xlValues, xlWhole).Column
intTargetCol = .Rows(1).Find("Advert", , xlValues, xlWhole).Column
Set rngPapers = Intersect(.Columns(intSourceCol), .UsedRange)
Set rngPaper = rngPapers.Find(strPaper, , xlValues, xlWhole)
If rngPaper Is Nothing Then
Set GetTours = New Collection
GoTo ExitHandler
Else
strAddress = rngPaper.Address
Do
strTour = .Cells(rngPaper.Row, intTargetCol).Text
On Error Resume Next
clnTours.Add strTour, strTour
On Error GoTo ErrorHandler
Set rngPaper = rngPapers.FindNext(rngPaper)
Loop Until (rngPaper.Address = strAddress)
End If
Set GetTours = clnTours
End With
ExitHandler:
Set clnTours = Nothing
Exit Function
ErrorHandler:
Set GetTours = New Collection
Resume ExitHandler
End Function
