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