Data extraction from multiple sheets

Vbalearner85

Board Regular
Joined
Jun 9, 2019
Messages
131
Office Version
  1. 2016
Platform
  1. Windows
Hello... I have the below macro which perfectly splits data for multiple unique values of column A from sheets ("Ddata", "Edata", "Fdata", "Gdata"), and adds new tab for each of the value data.

Need modification so as to pick up the same data (as of below macro) for one of the unique values (below macro is creating for each value of column A- new macro should do only for one value as selected) of column A, and give the result every time in Tab "Result" - pre-existing tab, for column A value selection in cell "Z1" of the same Tab "Result". So every time data should be fetched in Tab "Result" for the value selected in cell "Z1" of Tab "Result" when Macro is run. Also, it should not disturb source data unfiltered/non-modified @ end in source tabs.

Thanks in Advance..below is the macro which needs modification/create new macro as appropriate.


VBA Code:
Sub SplitData()
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("Ddata", "Edata", "Fdata", "Gdata")
    For i = LBound(ary) To UBound(ary)
        With Sheets(ary(i))
            lr = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
            If lr > 1 Then
               .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 If
        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
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

Forum statistics

Threads
1,148,239
Messages
5,745,573
Members
423,960
Latest member
sainoz

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