Please Modify My Macro

[domex]

Hi Guys,


Im using the below given macro to sort data from column A, from first sheet then split the sorted data into other sheet.

Now the problem is when column A contains huge data on specifc sort it takes very long time.

For e.g. If i sort column A as Apple the result is around 5000 rows then it creates the new sheet as apple and paste the data from sorted column but when the no is huge it take soooooooooo long time.

Kindly modify the macro to save my time.

My requirement is just sort data from column A one by one then paste it into other worksheets then rename the sheet.

Thanks in Advance.

Option Explicit

Sub Splitdatatosheets()
'
' Splitdatatosheets Macro
'

'
Dim rng As Range

Dim rng1 As Range

Dim vrb As Boolean

Dim sht As Worksheet

Set rng = Sheets("Sheet1").Range("A4")

Set rng1 = Sheets("Sheet1").Range("A4:R4")

vrb = False


Do While rng <> ""

    For Each sht In Worksheets
    
        If sht.Name = rng.Value Then
        
            sht.Select
               
            Range("A2").Select
               
            Do While Selection <> ""
               
                ActiveCell.Offset(1, 0).Activate
                    
            Loop
                    
            rng1.Copy ActiveCell
                
            ActiveCell.Offset(1, 0).Activate
                
            Set rng1 = rng1.Offset(1, 0)
                
            Set rng = rng.Offset(1, 0)
                
            vrb = True
            
        End If

    Next sht
    
    If vrb = False Then

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = rng.Value

    Sheets("Sheet1").Range("A3:R3").Copy ActiveSheet.Range("A1")

    Range("A2").Select
               
    Do While Selection <> ""
               
        ActiveCell.Offset(1, 0).Activate
                    
    Loop

    rng1.Copy ActiveCell

    Set rng1 = rng1.Offset(1, 0)
    
    Set rng = rng.Offset(1, 0)
    
    End If
    
vrb = False

Loop

End Sub

Please let me know if you require any clarification.

Ranjith

 

[VoG]

Try

Sub SplitDataToSheets()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With Sheets("Sheet1")
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = 18
    .Range(.Cells(4, 1), .Cells(LastRow, LastCol)).Sort Key1:=.Range("A4"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 4
    For i = 4 To LastRow
        If .Range("A" & i).Value <> .Range("A" & i + 1).Value Then
            iEnd = i
            If Not WorksheetExists(.Range("A" & iStart).Value) Then
                Sheets.Add after:=Sheets(Sheets.Count)
                Set ws = ActiveSheet
                On Error Resume Next
                ws.Name = .Range("A" & iStart).Value
                On Error GoTo 0
            Else
                Set ws = Sheets(.Range("A" & iStart).Value)
            End If
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function

 

[domex]

Its perfect .. thank u