VBA - De-duplicating columns, pasting vertical values horizontally

R

RockandGrohl

Well-known Member
Joined
Aug 1, 2018
Messages
801
Office Version
  1. 365
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:

[TABLE="class: grid, width: 800"]
<tbody>[TR]
[TD][/TD]
[TD]C[/TD]
[TD]M[/TD]
[TD]N[/TD]
[TD]Q[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Advert[/TD]
[TD]Code[/TD]
[TD]Paper Name[/TD]
[TD]Template Size[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Holland Cruise[/TD]
[TD]RT[/TD]
[TD]Kent Courier - Mon[/TD]
[TD]16x5[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]France Beach[/TD]
[TD]RT[/TD]
[TD]Kent Courier - Mon[/TD]
[TD]16x5[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]Portsmouth History[/TD]
[TD]RT[/TD]
[TD]Kent Courier - Fri[/TD]
[TD]16x5[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]Scarborough Fair[/TD]
[TD]RT[/TD]
[TD]Kent Courier - Fri[/TD]
[TD]16x5[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]Thursford[/TD]
[TD]RT[/TD]
[TD]Oxford Times[/TD]
[TD]16x9[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]Wales in Spring[/TD]
[TD]ROP[/TD]
[TD]Ashbourne News[/TD]
[TD]17x6[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]Oxford Weekend[/TD]
[TD]ROP[/TD]
[TD]Ashbourne News[/TD]
[TD]17x6[/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]Bournemouth Party[/TD]
[TD]ROP[/TD]
[TD]Ashbourne News[/TD]
[TD]17x6[/TD]
[/TR]
</tbody>[/TABLE]


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:

[TABLE="class: grid, width: 800"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Paper[/TD]
[TD]Template[/TD]
[TD]Code[/TD]
[TD]Tour 1[/TD]
[TD]Tour 2[/TD]
[TD]Tour 3[/TD]
[TD]Tour 4[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Ashbourne News[/TD]
[TD]17x6[/TD]
[TD]ROP[/TD]
[TD]Wales in Spring[/TD]
[TD]Oxford Weekend[/TD]
[TD]Bournemouth Party[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]Kent Courier - Mon[/TD]
[TD]16x5[/TD]
[TD]RT[/TD]
[TD]Holland Cruise[/TD]
[TD]France Beach[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]Kent Courier - Fri[/TD]
[TD]16x5[/TD]
[TD]RT[/TD]
[TD]Portsmouth History[/TD]
[TD]Scarborough Fair[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]Oxford Times[/TD]
[TD]16x9[/TD]
[TD]RT[/TD]
[TD]Thursford[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


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

Hoping you guys can help, thanks!
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Sort by date Sort by votes
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
 
Upvote 0
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
Click to expand...

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.
 
Upvote 0
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 ??
 
Upvote 0
MickG said:
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 ??
Click to expand...

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.
 
Upvote 0
MickG said:
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
Click to expand...


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!
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,910
Messages
6,175,316
Members
452,634
Latest member
cpostell

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top