VBA - De-duplicating columns, pasting vertical values horizontally

RockandGrohl

Active Member
Joined
Aug 1, 2018
Messages
459
Office Version
  1. 2010
Platform
  1. Windows
Hello all,

I hope this is a nice simple fix but I can't work it out.

I have two sheets P - Paste and F - Front

On Paste sheet, the four relevant columns are:

CMNQ
1AdvertCodePaper NameTemplate Size
2Holland CruiseRTKent Courier - Mon16x5
3France BeachRTKent Courier - Mon16x5
4Portsmouth HistoryRTKent Courier - Fri16x5
5Scarborough FairRTKent Courier - Fri16x5
6
ThursfordRTOxford Times16x9
7Wales in SpringROPAshbourne News17x6
8Oxford WeekendROPAshbourne News17x6
9Bournemouth PartyROPAshbourne News17x6

<tbody>
</tbody>


What I need to do is select the information here and paste it into Front worksheet, with some caveats:

The information in column N needs to be du-duplicated and pasted vertically down in Column A.

The Adverts in Column C need to be pasted horizontally. The end result should look like this:

ABCDEFG
1PaperTemplateCodeTour 1Tour 2Tour 3Tour 4
2Ashbourne News17x6ROPWales in SpringOxford WeekendBournemouth Party
3Kent Courier - Mon16x5RTHolland CruiseFrance Beach
4Kent Courier - Fri16x5RTPortsmouth HistoryScarborough Fair
5Oxford Times16x9RTThursford
6
7
8
9

<tbody>
</tbody>


The idea is to get a quick summary of which paper provided which adverts.

Hoping you guys can help, thanks!
 

Some videos you may like

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this for results in sheet "Front".
Code:
[COLOR="Navy"]Sub[/COLOR] MG06Nov23
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range, K [COLOR="Navy"]As[/COLOR] Variant, ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Paste")
    [COLOR="Navy"]Set[/COLOR] Rng = Range("N2", Range("N" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

ReDim Ray(1 To Rng.Count + 1, 1 To 3)
Ray(1, 1) = "Paper": Ray(1, 2) = "Template": Ray(1, 3) = "Code"
n = 1


[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
   n = n + 1: ac = 3
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K)
        Ray(n, 1) = R.Value
        Ray(n, 2) = R.Offset(, 3).Value
        Ray(n, 3) = R.Offset(, -1).Value
        ac = ac + 1
        [COLOR="Navy"]If[/COLOR] UBound(Ray, 2) < ac [COLOR="Navy"]Then[/COLOR]
         ReDim Preserve Ray(1 To Rng.Count + 1, 1 To ac)
        [COLOR="Navy"]End[/COLOR] If
        Ray(n, ac) = R.Offset(, -11).Value
        Ray(1, ac) = "Tour " & ac - 3
    [COLOR="Navy"]Next[/COLOR] R

[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
 [COLOR="Navy"]With[/COLOR] Sheets("Front").Range("A1").Resize(n, UBound(Ray, 2))
    .Value = Ray
    .Columns.AutoFit
    .Borders.Weight = 2
    .Sort .Parent.Range("A1"), Header:=xlYes
 [COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

RockandGrohl

Active Member
Joined
Aug 1, 2018
Messages
459
Office Version
  1. 2010
Platform
  1. Windows
Hi Mick,

During posting this and seeing your response this is what I had so far:

Sub DisplayData()

Dim Lastrow As Long


'Bring in Advert names and De-dupe
Sheets("Paste").Select
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Range("N1:N" & Lastrow).Copy
Sheets("Front").Select
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Paste").Select
Range("Q1:Q" & Lastrow).Copy
Sheets("Front").Select
Range("B2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Paste").Select
Range("M1:M" & Lastrow).Copy
Sheets("Front").Select
Range("C2").Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A2:C2").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Range("$A$2:$C$940").RemoveDuplicates Columns:=Array(1, 2, 3), _
Header:=xlNo
Columns("A:A").EntireColumn.AutoFit
Cells(2, 1).Select

' Bring in Template

Do Until Cells(ActiveCell.Row, "A") = ""
Cells(ActiveCell.Row, "B").Formula = "=IFERROR(VLOOKUP(RC[-1],Paste!C[12]:C[15],4,0),"""")"
Cells(ActiveCell.Row, "B").Value = Cells(ActiveCell.Row, "B").Value
Cells(ActiveCell.Row, "C").Formula = "=IFERROR(INDEX(Paste!C[10],MATCH(Front!RC[-2],Paste!C[11],0)),"""")"
Cells(ActiveCell.Row, "C").Value = Cells(ActiveCell.Row, "C").Value
ActiveCell.Offset(1, 0).Activate
Loop


Columns("C:C").EntireColumn.AutoFit


End Sub

This brings me to getting a de-duplicated list of unique papers, templates and codes which now need to be filled in with the adverts found.

Your VBA looks incredibly sophisticated and almost seems a different style entirely to what I've been taught so I'm having trouble understanding it.

is the "For Each K in .keys" that's looking for distinct values
Then it says n is n+ however many distinct values there are. So that's determining how many tours it needs to copy out.

The rest of it seems to get a little hazy. Ray R.offset? Thanks for the help.
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841

ADVERTISEMENT

I'm not really sure what you would me to do !!!
Firstly does the code work for you ???
If so would you like me right some remarks within the code so you could better understand it ??
 

RockandGrohl

Active Member
Joined
Aug 1, 2018
Messages
459
Office Version
  1. 2010
Platform
  1. Windows
I'm not really sure what you would me to do !!!
Firstly does the code work for you ???
If so would you like me right some remarks within the code so you could better understand it ??

Sorry I wasn't clear enough - I understand the first part, but I already have something that produces the same result - it provides a list of all papers along with their codes and template sizes.

Now I need to match the tours to the correct paper and template size.

When I put your code in a new module it created the front page and populated the cells at the top with the titles but failed to bring through any tours.
 

RockandGrohl

Active Member
Joined
Aug 1, 2018
Messages
459
Office Version
  1. 2010
Platform
  1. Windows
Here is file example of your data with results, hopefully you can incorporate it into a result that suit you Data.
I have added remarks to code for clarity !!
https://app.box.com/s/vvunj49a05viiryedxzq11ydhr2fe7t5


The remarks really do help with clarity, thank you. Like I said before - your code is incredibly sophisticated. It is much much faster than doing loops. Only one cause for concern is that it does not currently distinguish between different template sizes. But I don't think I added this in my example so don't worry about it. Cheers!
 

ParamRay

Well-known Member
Joined
Aug 6, 2014
Messages
1,195
Just in case you want a alternative macro, here's how I did it. Just change the names of the worksheets at the top where indicated:

Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,109,072
Messages
5,526,640
Members
409,713
Latest member
roman9980

This Week's Hot Topics

Top