Macro Modification for error

[Vbalearner85]

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

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

 

[Fluff]

How about

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, Fnd As Range
Set nsh = Sheets.Add(After:=Sheets(Sheets.Count))
ary = Array("data", "Edata", "Fdata", "Gdata")
    For i = LBound(ary) To UBound(ary)
        With Sheets(ary(i))
            Set Fnd = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious)
            If Not Fnd Is Nothing Then
               lr = Fnd.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 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

 

[Vbalearner85]

The above solution works when I remove the headers as well from row 1(from no data sheets), else stops @ below line

I think I missed telling you that each source datasheet has pre-existing header row 1 (which has text headers).

  lr = Fnd.Row
               .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , .Cells(lr + 3, 2), True

 

[Fluff]

In that case it's even easier

    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

 

[Vbalearner85]

Awesome sir..thanks for the prompt solution .

One small follow-up macro request - I want to pick up the same data (as an above macro) for one of the unique values (above macro is creating for each value of column A- this 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.

Thanks

 

[Fluff]

As this is a totally different question it needs it's own thread. Thanks

 

[Vbalearner85]

Thanks for the response..will post it as a separate thread.

Regards

 

[Fluff]

Glad to help & thanks for the feedback.