VBA, Sorting data in worksheets by unqiue strings - vba

Question

My current macro takes my data row by row from workbook A or worksheet A and splits it into different sheets based on matching headers. I am having trouble taking it a step further and splitting the string fields among these sheets.
For example, my data in workbook A, column B, contains 10 unique strings, how can I sort string x to one sheet only, and strings the rest of them to other sheets. So the row that contains sheet x will go to a certain sheet and strings abc will act as normal.
Here is my code so far, specifically call out the workbook and sheet names so it is not dynamic:
Option Explicit
Sub main()
Dim dsRng As Range
Dim sht As Worksheet
Dim AShtColsList As String, BShtColsList As String
Set dsRng = Workbooks("Workbook A").Worksheets("Sample Extract").Range("A1").CurrentRegion '<--| set your entire data set range in workbook "A" worksheet "ShtA" (change "A" and "ShtA" to your actual names)
dsRng.Sort key1:=dsRng.Range("A1"), order1:=xlAscending, Header:=xlYes '<--| sort data set range on its 1st column (which is "A", beginning it from column "A")
With Workbooks("Workbook B") '<--| refer "B" workbook
For Each sht In .Worksheets(Array("Stack", "Documentation", "Users")) '<--| loop through its worksheets
GetCorrespondingColumns dsRng, sht, AShtColsList, BShtColsList '<--| build lists of corresponding columns indexes in both workbooks
CopyColumns dsRng, sht, AShtColsList, BShtColsList '<--| copy listed columns between workbooks
Next sht
End With
End Sub
Sub GetCorrespondingColumns(dsRng As Range, sht As Worksheet, AShtColsList As String, BShtColsList As String)
Dim f As Range, c As Range
Dim iElem As Long
AShtColsList = "" '<--| initialize workbook "A" columns indexes list
BShtColsList = "" '<--| initialize workbook "B" current sheet columns indexes list
For Each c In sht.Rows(2).SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through workbook "B" current sheet headers in row 2 *******
Set f = dsRng.Rows(1).Find(what:=c.Value, lookat:=xlWhole, LookIn:=xlValues) '<--| look up data set headers row for workbook "B" current sheet current column header
If Not f Is Nothing Then '<--| if it's been found ...
BShtColsList = BShtColsList & c.Column & "," '<--| ...update workbook "B" current sheet columns list with current header column index
AShtColsList = AShtColsList & f.Column & "," '<--| ...update workbook "A" columns list with corresponding found header column index
End If
Next c
End Sub
Sub CopyColumns(dsRng As Range, sht As Worksheet, AShtColsList As String, BShtColsList As String)
Dim iElem As Long
Dim AShtColsArr As Variant, BShtColsArr As Variant
If AShtColsList <> "" Then '<--| if any workbook "B" current sheet header has been found in workbook "A" data set headers
BShtColsArr = Split(Left(BShtColsList, Len(BShtColsList) - 1), ",") '<--| build an array out of workbook "B" current sheet columns indexes list
AShtColsArr = Split(Left(AShtColsList, Len(AShtColsList) - 1), ",") '<--| build an array out of workbook "A" corresponding columns indexes list
For iElem = 0 To UBound(AShtColsArr) '<--| loop through workbook "A" columns indexes array (you could have used workbook "A" corresponding columns indexes list as well)
Intersect(dsRng, dsRng.Columns(CLng(AShtColsArr(iElem)))).Copy sht.Cells(2, CLng(BShtColsArr(iElem))) '<--| copy data set current column into workbook "B" current sheet corresponding column starting from row 2 *******
Next iElem
End If
End Sub
Thanks.
EDIT
Complete extract. Call this Sample extract in workbook B.
'Users' Sheet. My Macro already does this.
'Documentation' Sheet, my macro already does this too
'Stack' Sheet. my macro does not do this. It filtered the record stackoverflow and its pertaining columns.
Hopefully this helps.

Answer 1

get your data saved in sheet named "data". and below code will generate separate sheets for every unique value in column B with data of corresponding value.
Dim data, sht As Worksheet
Dim rng As Range
Dim counter As Long
Set data = ThisWorkbook.Sheets("data")
data.Activate
Range("B:B").Copy
Range("H:H").PasteSpecial xlPasteValues
Range("H:H").RemoveDuplicates Columns:=1, Header:=xlYes
Set rng = data.Range("H2")
Do While rng.Value <> ""
Set sht = ThisWorkbook.Worksheets.Add
sht.Name = rng.Value
data.Activate
ActiveSheet.AutoFilterMode = False
Range("A1").AutoFilter field:=2, Criteria1:=rng.Value
Range("A1:C1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlVisible).Copy
sht.Activate
Range("A1").PasteSpecial xlPasteValues
Range("A1").Activate
Set rng = rng.Offset(1, 0)
Loop
It will create sheets in same workbook.