VBA to Split data from 3 worksheets based upon column "A" values into separate tab for each distinct value

[Vbalearner85]

Hi All,

I have a macro (below) which splits the data from sheet "Adata" of workbook based on column "A" distinct values into separate sheets.

What I want to do is modify Macro to also repeat the same process(split data) in sequence for another 2 sheets "Bdata" and " Cdata" of the same workbook and provide resultant data in same sheets based upon values of column "A". Please note All three sheets "Adata/Bdata/Cdata) have similar values in column "A". Data must be copied in sequence-First from "Adata" and then from "BData" (below data from A data) and then from "CData" (below data from b data) in resultant worksheets . Thanks !!!

Sub Split_Sht_in_Separate_Shts()

Const FirstC As String = "A" '1st column

Const LastC As String = "M" 'last column

Const sCol As String = "A" '<<< Criteria in Column B

Const shN As String = "Adata" '<<< Source Sheet

Dim ws As Worksheet, ws1 As Worksheet

Set ws = Sheets(shN)

Dim rng As Range

Dim r As Long, c As Long, x As Long, r1 As Long

Application.ScreenUpdating = False

r = ws.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

c = ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2

Set rng = ws.Range(ws.Cells(1, FirstC), ws.Cells(r, LastC))

ws.Range(sCol & ":" & sCol).Copy

ws.Cells(1, c).PasteSpecial xlValues

Application.CutCopyMode = False

ws.Cells(1, c).Resize(r).RemoveDuplicates Columns:=1, Header:=xlYes

r1 = ws.Cells(Rows.Count, c).End(xlUp).Row

ws.Cells(1, c).Resize(r1).Sort Key1:=ws.Cells(1, c), Header:=xlYes

ws.AutoFilterMode = False

Application.DisplayAlerts = False

For x = 2 To r1

For Each ws1 In Sheets

If ws1.Name = ws.Cells(x, c) Then ws1.Delete

Next

Next

Application.DisplayAlerts = True

For x = 2 To r1

ws.Range(ws.Cells(1, sCol), ws.Cells(r, sCol)).AutoFilter Field:=1, Criteria1:=ws.Cells(x, c)

Set ws1 = Worksheets.Add(after:=Worksheets(Worksheets.Count))

ws1.Name = ws.Cells(x, c).Value

rng.SpecialCells(xlCellTypeVisible).Copy

Range("A1").PasteSpecial Paste:=xlPasteFormats

Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

Range("A1").PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False

Next x

With ws

.AutoFilterMode = False

.Cells(1, c).Resize(r).ClearContents

.Activate

.Range("A1").Select

End With

Application.ScreenUpdating = True

End Sub

 

[JLGWhiz]

Barring any typos, this should work.

Sub Split_Sht_in_Sepatate_Shts_Rev()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, nsh As Worksheet, rng As Range, ary As Variant
Dim i As Long, lr As Long, c As Range, cel As Range
Set sh1 = Sheets("AData")
Set sh2 = Sheets("BData")
Set sh3 = Sheets("CData")
Set nsh = Sheets.Add(After:=sh3)
ary = Array(sh1, sh2, sh3)
    For i = LBound(ary) To UBound(ary)
        With ary(i)
            lr = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
            .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AdvanceFilter xlFilterCopy, , .Cells(lr + 3, 2), True
            Set rng = .Cells(lr + 4, 2).Resize(.Cells(lr + 3, 2).CurrentRegion - 1)
            rng.Sort .Cells(lr + 4, 2), xlAscending
            For Each c In rng
                .Range("A:A").AutoFilter 1, c.Value
                cel = nsh.Cells(Rows.Count, 1).End(xlUp)
                Intersect(.UsedRange, .Range("A:M")).SpecialCells(xlCellTypeVisible).Copy
                cel.PasteSpecial xlPasteFormats
                cel.PasteSpecial xlPasteColumnWidths
                cel.PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                .AutoFilterMode = False
            Next
            .Cells(lr + 3, 2).CurrentRegion.ClearContents
        End With
    Next
End Sub

 

[Vbalearner85]

Hi. "JLGWhiz"...Thanks for your time to look into this..I ran the code..but throws error at this line after adding "Sheet 1"...and stops

".Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AdvanceFilter xlFilterCopy, , .Cells(lr + 3, 2), True"

Please assist..

 

[JLGWhiz]

I did that in a hurry without testing last night and there were several errors in it which I have corrected and tested. Here is the revised code. See if you still get the error.

Sub Split_Sht_in_Sepatate_Shts_Rev()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, nsh As Worksheet, rng As Range, ary As Variant
Dim i As Long, lr As Long, c As Range, cel As Range
Set sh1 = Sheets("AData")
Set sh2 = Sheets("BData")
Set sh3 = Sheets("CData")
Set nsh = Sheets.Add(After:=sh3)
ary = Array(sh1, sh2, sh3)
    For i = LBound(ary) To UBound(ary)
        With ary(i)
            lr = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
            .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , .Cells(lr + 3, 2), True
            Set rng = .Cells(lr + 4, 2).Resize(.Cells(lr + 3, 2).CurrentRegion.Count - 1)
            rng.Sort .Cells(lr + 4, 2), xlAscending
            For Each c In rng
                .Range("A:A").AutoFilter 1, c.Value
                Set cel = nsh.Cells(Rows.Count, 1).End(xlUp)
                Intersect(.UsedRange.Offset(1), .Range("A:M")).SpecialCells(xlCellTypeVisible).Copy
                cel.PasteSpecial xlPasteFormats
                cel.PasteSpecial xlPasteColumnWidths
                cel.PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                .AutoFilterMode = False
            Next
            .Cells(lr + 3, 2).CurrentRegion.ClearContents
        End With
    Next
End Sub

 

[Vbalearner85]

Thanks..I might not be clear in my code request...code is working to consolidate multiple sheets into" Sheet 1"...My code aim is to split in into mutiple sheets based upon distinct column A value as well...which is not happening by above code....Please note consolidated data rows (from Adata+Bdata_Cdata) might exceed the limit of 1 excel sheet..that is the main challenge....Regards

 

[JLGWhiz]

Before I revise the code to produce multiple sheets, I need to know if these assumptions are valid, and if not, please provide clarification.
It is assumed that there will be duplicates of column A values between AData, BData and CData Sheets. True/False?
It is assumed that if more than one source sheet has the same values in column A that those values would then be listed in the same new worksheet with their corresponding details in other columns. True/ False?
It is assumed that the final product will be a quantity of new sheets equal to the number of unique values in Column a of the collective three source sheets. True/False?

In other words, If we made a single sheet that consolidated AData, BData and CData then removed all duplicates from column A the quantity of remaining values would equal the number of new worksheets. True/False?

 

[Vbalearner85]

Hi..sorry for late reply..way away from internet due to some family emergency...

Please see below responses.....
t is assumed that there will be duplicates of column A values between AData, BData and CData Sheets. True/False? TRUE
It is assumed that if more than one source sheet has the same values in column A that those values would then be listed in the same new worksheet with their corresponding details in other columns. True/ False? TRUE
It is assumed that the final product will be a quantity of new sheets equal to the number of unique values in Column a of the collective three source sheets. True/False? TRUE

In other words, If we made a single sheet that consolidated AData, BData and CData then removed all duplicates from column A the quantity of remaining values would equal the number of new worksheets. True/False? TRUE...but here is the catch...data rows combined together for AData, BData and CData would be around 3 milion and would be more than the range of 1 worksheet (1million)...

Looking for some innovation here..

Regards

 

[JLGWhiz]

I want to be absolutely clear on the output of sheets, since it appears there will be a large number if assumption 3 is true.
If in column A of source sheets AData, BData and CData there are values "A", "B", "C",, "D", "E", "F" in all three original sheets, then the output would be 6 sheets, one fore each unique value in column A of the collective source sheets. If not, then please give an illustration of what you expect to see as output.

 

[Vbalearner85]

Yes true..expected output is one worksheet each for distinct value for combined A column of source sheets AData, BData and CData

 

[JLGWhiz]

Lets give this one a shot

Sub Split_Sht_in_Sepatate_Shts_Rev2()
Dim sh As Worksheet, nsh As Worksheet, rng As Range, ary As Variant
Dim i As Long, lr As Long, c As Range, cel As Range
Set nsh = Sheets.Add(After:=Sheets(Sheets.Count))
ary = Array("AData", "BData", "CData")
    For i = LBound(ary) To UBound(ary)
        With Sheets(ary(i))
            lr = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
            .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , .Cells(lr + 3, 2), True
            Set rng = .Cells(lr + 4, 2).CurrentRegion.Offset(1)
            rng.Sort .Cells(lr + 4, 2), xlAscending
            rng.Copy nsh.Cells(Rows.Count, 1).End(xlUp)(2)
            rng.CurrentRegion.ClearContents
        End With
    Next
nsh.UsedRange.Sort nsh.Range("A1"), xlAscending
nsh.Columns(1).RemoveDuplicates 1, xlNo
Set rng = nsh.UsedRange
    For Each c In rng
        Set sh = Sheets.Add(After:=Sheets(Sheets.Count))
        sh.Name = c.Value
        For j = LBound(ary) To UBound(ary)
            With Sheets(ary(j))
                .UsedRange.AutoFilter 1, c.Value
                If sh.Range("A1") = "" Then
                    .UsedRange.Copy sh.Range("A1")
                Else
                    .UsedRange.Offset(1).Copy sh.Cells(Rows.Count, 1).End(xlUp)(2)
                End If
                .AutoFilterMode = False
            End With
        Next
    Next
Application.DisplayAlerts = False
nsh.Delete
Application.DisplayAlerts = True
End Sub