Macro Modification for error

Vbalearner85

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

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
 

Excel Facts

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

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,666
Office Version
  1. 365
Platform
  1. Windows
How about
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, 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

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

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

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,666
Office Version
  1. 365
Platform
  1. Windows
In that case it's even easier
VBA Code:
    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
 
Solution

Vbalearner85

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

ADVERTISEMENT

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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,666
Office Version
  1. 365
Platform
  1. Windows
As this is a totally different question it needs it's own thread. Thanks
 

Vbalearner85

Board Regular
Joined
Jun 9, 2019
Messages
121
Office Version
  1. 2016
Platform
  1. Windows
Thanks for the response..will post it as a separate thread.

Regards
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,666
Office Version
  1. 365
Platform
  1. Windows
Glad to help & thanks for the feedback.
 

Forum statistics

Threads
1,141,863
Messages
5,709,063
Members
421,611
Latest member
Lisa W

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