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

Vbalearner85

Board Regular
Joined
Jun 9, 2019
Messages
85
Office Version
  1. 2016
Platform
  1. Windows
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
 

Some videos you may like

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Barring any typos, this should work.

VBA Code:
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

Board Regular
Joined
Jun 9, 2019
Messages
85
Office Version
  1. 2016
Platform
  1. Windows
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

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
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.

VBA Code:
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

Board Regular
Joined
Jun 9, 2019
Messages
85
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

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

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
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

Board Regular
Joined
Jun 9, 2019
Messages
85
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

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

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
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

Board Regular
Joined
Jun 9, 2019
Messages
85
Office Version
  1. 2016
Platform
  1. Windows
Yes true..expected output is one worksheet each for distinct value for combined A column of source sheets AData, BData and CData
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Lets give this one a shot

VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,122,985
Messages
5,599,201
Members
414,296
Latest member
nachname

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top