VBA code for splitting table data into new workbooks

[Reecenorman1996]

Hi im looking for a vba code that will separate the client and applicant solicitors onto new workbook and save them atm i have to filter client sol copy and paste ona new sheet then filter app sol then copy paste that on a new sheet , i need all Test law to go onto a new workbook from applicant sol and client sol columns and the same with Test 2 law and test 3 law. so end result would be 3 workbooks test law, test 2 law and test 3 law. so i need the solicitors name from both columns to go onto a new workbook.

Office	Property	Client	Applicant Solicitor	Client Solicitor	Sale Agreed Date
Hereford	Test	Reece	Test law	Test 2 law	26/07/2023 17:51
Banbury	Test	Reece	Test 2 law	Test law	26/07/2023 16:56
Headington	Test	Reece	Test 2 law	Test 3 law	26/07/2023 16:43
High Wycombe	Test	Reece	test 3 law	Test 2 law	21/07/2023 15:34

 

[RudRud]

Hi, Kindly show the sample of save result here

For Example: Filter Test Law in Applicant Solicitor then move into next workbook sheet1 for applicant solicitor & sheet2 for client solicitor (1Workbook 2 Worksheets) ? Something like this?

It would be good if you show us the desire result instead

 

[Reecenorman1996]

So it should look like this for test law

Office	Property	Client	Applicant Solicitor	Client Solicitor	Sale Agreed Date
Hereford	Test	Reece	Test law	Test 3 law	26/07/2023 17:51
Banbury	Test	Reece	Test 2 law	Test law	26/07/2023 16:56

This for test law 2 is doesnt matter what column test law 2 is in it will all go into a new workbook , hope this helps

Office	Property	Client	Applicant Solicitor	Client Solicitor	Sale Agreed Date
Hereford	Test	Reece	Test law	Test 2 law	26/07/2023 17:51
Banbury	Test	Reece	Test 2 law	Test law	26/07/2023 16:56
Headington	Test	Reece	Test 2 law	Test 3 law	26/07/2023 16:43
High Wycombe	Test	Reece	test 3 law	Test 2 law	21/07/2023 15:34

 

[RudRud]

Please give a shot, assuming your data is from A1 to F

Set ws = Sheets("sheet1") -- please give a change if your site is not in sheet1

For now the adding workbooks will save in your current folder path

Option Compare Text
Option Explicit
Sub test()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim a As Variant, B As Variant, Key As Variant
Dim k%, i%
Dim ss As Range
Dim ws As Worksheet
Set ws = Sheets("sheet1")
ReDim B(1 To 100000, 1 To 6)
Dim wb As Workbook
Set wb = ThisWorkbook

Application.ScreenUpdating = False
'Array Values from Col A - F
a = ws.Range("a2:f" & ws.Cells(Rows.Count, "a").End(xlUp).Row).Value 'Change if your data is not from a2 to f

With ws
    'Copy Column E Values to I then remove duplicates to create unique values
    .[i:i].ClearContents
    .Range("e2:e" & .Cells(Rows.Count, "E").End(xlUp).Row).Copy .[i1]
    .[i:i].RemoveDuplicates Columns:=1, Header:=xlNo
End With

'Loop through unique values and store into dictionary
For Each ss In ws.Range("i1:i" & ws.Cells(Rows.Count, "I").End(xlUp).Row)
    k = k + 1
    dict.Add ss.Value, k
Next ss


For Each Key In dict.Keys 'Loop through test 2 law test law test 3 law
           k = 0
           For i = 1 To UBound(a, 1)
            If a(i, 4) = Key Or a(i, 5) = Key Then ' If existing
                k = k + 1
                B(k, 1) = a(i, 1)
                B(k, 2) = a(i, 2)
                B(k, 3) = a(i, 3)
                B(k, 4) = a(i, 4)
                B(k, 5) = a(i, 5)
                B(k, 6) = a(i, 6)
            End If
         Next i
    
        Workbooks.Add
   
        With ActiveWorkbook
            [a1].Value = "Office"
            [b1].Value = "Property"
            [c1].Value = "Client"
            [d1].Value = "Applicant Solicitor"
            [e1].Value = "Client Solicitor"
            [f1].Value = "Sale Agreed Date"
            [a2].Resize(UBound(B, 1), UBound(B, 2)).Value = B
            Columns("A:F").AutoFit
            [a1:f1].HorizontalAlignment = xlCenter
            [a1:f1].VerticalAlignment = xlCenter
            ActiveSheet.Name = Key
            .SaveAs Filename:=wb.Path & "\" & Key
            .Close
        End With

        ReDim B(1 To 100000, 1 To 6) 'Clear Array

Next Key

MsgBox "All data has been imported"
Application.ScreenUpdating = True

End Sub