Solved

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

Posted on 2013-11-11
3
580 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 32

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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

920 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

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now