Solved: Create worksheets based on column

[Jdelpheki]

i have been tring unsuccessfully to create a macro to scan column B and create a worksheet from each unique string value. any help would be greatly appreciated.

[mvidas]

Hi Jdelpheki,

Give the following a try, should do all you're looking for.Sub SplitIntoMultipleSheetsBasedOnColumn()
Dim TheColumn As Range, CLL As Range, UniqVals() As Variant
Dim FirstDataRow As Long, i As Long, iLB As Long, iUB As Long
Set TheColumn = Columns("B")
FirstDataRow = 2 'so that the header row(s) aren't turned into a sheet
ReDim UniqVals(0)
For Each CLL In Range(TheColumn.Cells(FirstDataRow), TheColumn.Cells(Rows.Count).End(xlUp))
If Not InArray(UniqVals, CLL) Then
UniqVals(UBound(UniqVals)) = CLL
ReDim Preserve UniqVals(UBound(UniqVals) + 1)
End If
Next CLL
iLB = 0
iUB = UBound(UniqVals) - 1
ReDim Preserve UniqVals(iUB)
Application.ScreenUpdating = False
For i = iLB To iUB
Set CLL = FoundRange(TheColumn, UniqVals(i))
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = UniqVals(i)
If FirstDataRow > 1 Then Range(TheColumn.Cells(1), TheColumn.Cells _
(FirstDataRow - 1)).EntireRow.Copy ActiveSheet.Range("A1")
CLL.EntireRow.Copy ActiveSheet.Range("A" & FirstDataRow)
Next i
Application.ScreenUpdating = True
End Sub
Public Function InArray(ByRef vArray(), ByVal vValue) As Boolean
Dim i As Long, iLB As Long, iUB As Long
iLB = LBound(vArray)
iUB = UBound(vArray)
For i = iLB To iUB
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 FunctionIt also copies the relavant data onto each sheet, if you dont need that then comment out the following parts of the last For loop: For i = iLB To iUB
' Set CLL = FoundRange(TheColumn, UniqVals(i))
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = UniqVals(i)
' If FirstDataRow > 1 Then Range(TheColumn.Cells(1), TheColumn.Cells _
(FirstDataRow - 1)).EntireRow.Copy ActiveSheet.Range("A1")
' CLL.EntireRow.Copy ActiveSheet.Range("A" & FirstDataRow)
Next iMatt

[Bob Phillips]

Public Function InArray(ByRef vArray(), ByVal vValue) As Boolean
InArray = Not (IsError(Application.Match(vValue, vArray, 0)))
End Function

[mvidas]

:)
You think that is any faster than iterating through it? I use mine in case I need to modify it to only look at the first X characters or need to know the index within the array. Plus (and I CANT remember the circumstances), there was one time where I couldnt get application.match to work the way I wanted, so just kept it as my function from that point on.

[Norie]

Here's a way using advanced filter.

Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long

Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on

LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row

Set wsCrit = Worksheets.Add

' column B has the criteria eg project ref
wsAll.Range("B1:B" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True

LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
For I = 2 To LastRowCrit

Set wsNew = Worksheets.Add
wsNew.Name = wsCrit.Range("A2")
wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
CopyToRange:=wsNew.Range("A1"), Unique:=False
wsCrit.Rows(2).Delete

Next I

Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True

End Sub

[Jdelpheki]

Mdivas your code worked great!

[Pam in TX]

I am pretty new to developing macros..... and this is 95% of a macro I am looking for.....

The other piece that I need is that at the bottom of the sheet I have several rows that add up specific items in certain columns, and I need that information to travel over to the unique sheets also.... right now I can get it to move over but it loses the formulas...

Any help would be greatly appreciated.....

[Bob Phillips]

look at PasteSpecial in help.

[Pam in TX]

look at PasteSpecial in help.

Not sure what you mean????

Are you saying adding that into the macro????

[Bob Phillips]

I am saying that PasteSpecial gives you different pasting options, as explained in help.

[Pam in TX]

I am saying that PasteSpecial gives you different pasting options, as explained in help.

I know about paste special and its functions, but are you saying to add that to the Macro?

I guess I will give that a try....

[Bob Phillips]

I am talking about VBA PasteSpecial. Look in VBA Help and ask specific questions if you have any.