Vbalearner85
Board Regular
- Joined
- Jun 9, 2019
- Messages
- 139
- Office Version
- 2016
- Platform
- Windows
Hello... I have the below macro which splits data for values of column A from sheets ("Ddata", "Edata", "Fdata", "Gdata"). Macro works well but gives runtime error, whenever any of the source data sheets("Ddata", "Edata", "Fdata", "Gdata")) have no data.
Need modification so that macro should work even if one or more source data sheets("Ddata", "Edata", "Fdata", "Gdata") have data in it and ignore blank source datasheets.
Thanks in Advance..below is the macro which needs modification
Need modification so that macro should work even if one or more source data sheets("Ddata", "Edata", "Fdata", "Gdata") have data in it and ignore blank source datasheets.
Thanks in Advance..below is the macro which needs modification
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
.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