?
Solved

Excel Worksheet from Unique Values in Column and move corresponding Data.

Posted on 2013-11-11
3
Medium Priority
?
596 Views
Last Modified: 2013-11-11
Hi EE,

I need some help with a VB script/Macro to create/add worksheets based off the unique  distinct values of a specific column in a master worksheet (Column C in Master).
Then move/add the matching values to the corresponding worksheet.

So with the example below there is only 3 distinct values (Cat A, Cat B, Cat C) in column C
Master
Using the values create the worksheets.
CAT A and move all the corresponding value from master
CAT ACAT B and move all the corresponding value from master
CAT BCAT C and move all the corresponding value from master
Cat C
Thank You EE
0
Comment
Question by:Ross Turner
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
3 Comments
 
LVL 35

Accepted Solution

by:
mvidas earned 2000 total points
ID: 39639487
Hi Ross,

Give the following a try. I've used this for a while, and should do what you're looking for. It will go a bit faster if you have it sorted by column C at first, but will work regardless. I have it set to sort on column C, with data starting in row 2; change the settings at the top if this is not correct.
Option Explicit
Sub SplitIntoMultipleSheetsBasedOnColumn()
 Dim TheColumn As Range, ValRG As Range
 Dim UniqVals() As Variant, AllVals() As Variant
 Dim FirstDataRow As Long, i As Long, Cnt As Long
 
 'Unique values in the column specified by TheColumn are given their own worksheet,
 ' and their entire row is copied to that worksheet
 Set TheColumn = Columns("C") 'must be a single column
 FirstDataRow = 2 'so that the header row(s) aren't turned into a sheet
 
 Set ValRG = Intersect(TheColumn, TheColumn.Worksheet.UsedRange, _
  TheColumn.Worksheet.Rows(FirstDataRow & ":" & TheColumn.Worksheet.Rows.Count))
 If ValRG Is Nothing Then
  MsgBox "No data found. Exiting."
  Exit Sub
 End If
 ReDim UniqVals(0)
 Cnt = 0
 AllVals = ValRG.Value
 For i = 1 To UBound(AllVals, 1)
  If Not InArray(UniqVals, AllVals(i, 1)) Then
   ReDim Preserve UniqVals(Cnt)
   UniqVals(Cnt) = AllVals(i, 1)
   Cnt = Cnt + 1
  End If
 Next 'i
 
 Application.ScreenUpdating = False
 For i = LBound(UniqVals) To UBound(UniqVals)
  Set ValRG = FoundRange(TheColumn, UniqVals(i))
  With Sheets.Add(After:=Sheets(Sheets.Count))
   On Error Resume Next
   .Name = ValidSheetName(UniqVals(i))
   On Error GoTo 0
   If FirstDataRow > 1 Then TheColumn.Worksheet.Range(TheColumn.Cells(1), _
    TheColumn.Cells(FirstDataRow - 1)).EntireRow.Copy .Range("A1")
   ValRG.EntireRow.Copy .Range("A" & FirstDataRow)
  End With
 Next 'i
 Application.ScreenUpdating = True
End Sub
Private Function ValidSheetName(ByVal DesiredSheetName As String) As String
 On Error Resume Next
 ValidSheetName = Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
  DesiredSheetName, ":", ""), "\", ""), "/", ""), "?", ""), "*", ""), "[", ""), _
  "]", ""), 31)
End Function
Public Function InArray(ByRef vArray(), ByVal vValue) As Boolean
 Dim i As Long
 For i = LBound(vArray) To UBound(vArray)
  If vArray(i) = vValue Then
   InArray = True
   Exit Function
  End If
 Next 'i
 InArray = False
End Function
Function FoundRange(ByVal vRG As Range, ByVal vVal) As Range
 Dim FND As Range, FND1 As Range
 Set FND = vRG.Find(vVal, LookIn:=xlValues, LookAt:=xlWhole)
 If Not FND Is Nothing Then
  Set FoundRange = FND
  Set FND1 = FND
  Set FND = vRG.FindNext(FND)
  Do Until FND.Address = FND1.Address
   Set FoundRange = Union(FoundRange, FND)
   Set FND = vRG.FindNext(FND)
  Loop
 End If
End Function

Open in new window

Matt
0
 
LVL 33

Expert Comment

by:Rob Henson
ID: 39639742
This is ideal scenario for Advanced Filter function with option to copy to another location selected. Just AF wouldn't create the tabs for you but it could be used to populate them.

Thanks
Rob H
0
 
LVL 7

Author Closing Comment

by:Ross Turner
ID: 39640167
Hi mvidas,

This was perfect.... did exactly what i was trying to achieve!

Thank you so much :)
0

Featured Post

Office 365 Training for IT Pros

Learn how to provision tenants, synchronize on-premise Active Directory, implement Single Sign-On, customize Office deployment, and protect your organization with eDiscovery and DLP policies.  Only from Platform Scholar.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

In Part II of this series, I will discuss how to identify all open instances of Excel and enumerate the workbooks, spreadsheets, and named ranges within each of those instances.
This article helps those who get the 0xc004d307 error when trying to rearm (reset the license) Office 2013 in a Virtual Desktop Infrastructure (VDI) and/or those trying to prep the master image for Microsoft Key Management (KMS) activation. (i.e.- C…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

752 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question