VBA, a collection of advanced filters, populate common columns in sheets

Question

I have book A with many columns and headings, I would like to separate this data and fill out book B based on the name of the heading (in book B there are 4 sheets of different pre-populated column headings)

1) Workbook A (many columns), filters for all its unique values ​​in col 'AN' (i.e. col AN has 20 unique values, but ~ 3000 rows for each unique set).

2) There is book B with pre-filled columns on 4 sheets, and not all the same headings as in book A. Here, unique values ​​from col AN from book A will be entered here with their corresponding entries, one after the other.

The goal is to populate these 4 sheets with data from book A, sorting for each unique value of column AN with its entries in pre-filled book B.

This code still uniquely filters my main column "AN" and just gets unique values, I need unique values ​​along with the records.

Sub Sort()


Dim wb As Workbook, fileNames As Object, errCheck As Boolean
    Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
    Dim y As Range, intRow As Long, i As Integer

Dim r As Range, lr As Long, myrg As Range, z As Range
    Dim boolWritten As Boolean, lngNextRow As Long
    Dim intColNode As Integer, intColScenario As Integer
    Dim intColNext As Integer, lngStartRow As Long
    Dim lngLastNode As Long, lngLastScen As Long


                                 ' Finds column AN , header named 'first name'
                intColScenario = 0
                On Error Resume Next
                intColScenario = WorksheetFunction.Match("First name", .Rows(1), 0)
                On Error GoTo 0

                If intColScenario > 0 Then
                     ' Only action if there is data in column E
                    If Application.WorksheetFunction.CountA(.Columns(intColScenario)) > 1 Then
                       lr = .Cells(.Rows.Count, intColScenario).End(xlUp).Row


                         ' Copy unique values from the formula column to the 'Unique data' sheet, and write sheet & file details
                        .Range(.Cells(1, intColScenario), .Cells(lr, intColScenario)).AdvancedFilter xlFilterCopy, , r, True
                        r.Offset(0, -2).Value = ws.Name
                        r.Offset(0, -3).Value = ws.Parent.Name



                         ' Delete the column header copied to the list
                        r.Delete Shift:=xlUp
                        boolWritten = True
                    End If
                End If


                 'I need to take the rest of the records with this though. 

' Reset system settings
With Application
   .Calculation = xlCalculationAutomatic
   .ScreenUpdating = True
   .Visible = True
End With
End Sub

Adding Sample Images

Workbook Sample, I want a unique filter "task column" to collect all related entries:

Workbook Example B, Sheet 1 (note that there will be multiple sheets). As you can see, book A was sorted by the "job" column.

Answer 1

you can use the following code:

"B" 2 ( 1 OP)

Option Explicit

Sub main()
    Dim dsRng As Range
    Dim sht As Worksheet
    Dim AShtColsList As String, BShtColsList As String

    Set dsRng = Workbooks("A").Worksheets("ShtA").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("AN1"), order1:=xlAscending, Header:=xlYes '<--| sort data set range on its 40th column (which is "AN", beginning it from column "A")

    With Workbooks("B") '<--| refer "B" workbook
        For Each sht In .Worksheets '<--| 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 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

, "B", , SubSeparateRowsSet() CopyColumns() main()