Solved

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

Posted on 2013-11-11
3
589 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
3 Comments
 
LVL 35

Accepted Solution

by:
mvidas earned 500 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

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Recently Microsoft released a brand new function called CONCAT. It's supposed to replace its predecessor CONCATENATE. But how does it work? And what's new? In this article, we take a closer look at all of this - we even included an exercise file for…
Using Word 2013, I was experiencing some incredible lag when typing.  Here's what worked for me....
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

809 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