Excel Forum

Code: Select all

Sub SortData()
Dim SortData As String

    Sheets.Add
     ActiveSheet.Name = "SortData"
     
    Sheets("Data").Select
    Range("A10:A17").Select
    Selection.Copy
    Sheets("SortData").Select
    Range("A1").Select
    ActiveSheet.Paste
    
    Sheets("Data").Select
    Range("B10:B17").Select
    Selection.Copy
    Sheets("SortData").Select
    Range("A9").Select
    ActiveSheet.Paste
    
    Sheets("Data").Select
    Range("C10:C17").Select
    Selection.Copy
    Sheets("SortData").Select
    Range("A17").Select
    ActiveSheet.Paste
    
    Sheets("Data").Select
    Range("D10:D17").Select
    Selection.Copy
    Sheets("SortData").Select
    Range("A25").Select
    ActiveSheet.Paste
    
    Sheets("Data").Select
    Range("E10:E17").Select
    Selection.Copy
    Sheets("SortData").Select
    Range("A33").Select
    ActiveSheet.Paste
    
     Sheets("Data").Select
    Range("F10:F17").Select
    Selection.Copy
    Sheets("SortData").Select
    Range("A41").Select
    ActiveSheet.Paste
    
     Sheets("Data").Select
    Range("G10:G17").Select
    Selection.Copy
    Sheets("SortData").Select
    Range("A49").Select
    ActiveSheet.Paste
    
    Sheets("Data").Select
    Range("H10:H17").Select
    Selection.Copy
    Sheets("SortData").Select
    Range("A57").Select
    ActiveSheet.Paste
    
    Sheets("Data").Select
    Range("I10:I17").Select
    Selection.Copy
    Sheets("SortData").Select
    Range("A65").Select
    ActiveSheet.Paste
    
    Sheets("Data").Select
    Range("J10:J17").Select
    Selection.Copy
    Sheets("SortData").Select
    Range("A73").Select
    ActiveSheet.Paste
    
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    
    Sheets("SortData").Select
    Range("A1:A8").Select
    Selection.Copy
    Sheets("Data").Select
    Range("A10").Select
    ActiveSheet.Paste
    
    Sheets("SortData").Select
    Range("A9:A16").Select
    Selection.Copy
    Sheets("Data").Select
    Range("B10").Select
    ActiveSheet.Paste
    
    Sheets("SortData").Select
    Range("A17:A24").Select
    Selection.Copy
    Sheets("Data").Select
    Range("C10").Select
    ActiveSheet.Paste
    
    Sheets("SortData").Select
    Range("A25:A32").Select
    Selection.Copy
    Sheets("Data").Select
    Range("D10").Select
    ActiveSheet.Paste
    
    Sheets("SortData").Select
    Range("A33:A40").Select
    Selection.Copy
    Sheets("Data").Select
    Range("E10").Select
    ActiveSheet.Paste
    
    Sheets("SortData").Select
    Range("A41:A48").Select
    Selection.Copy
    Sheets("Data").Select
    Range("F10").Select
    ActiveSheet.Paste
    
    Sheets("SortData").Select
    Range("A49:A56").Select
    Selection.Copy
    Sheets("Data").Select
    Range("G10").Select
    ActiveSheet.Paste
    
    Sheets("SortData").Select
    Range("A57:A64").Select
    Selection.Copy
    Sheets("Data").Select
    Range("H10").Select
    ActiveSheet.Paste
    
    Sheets("SortData").Select
    Range("A65:A72").Select
    Selection.Copy
    Sheets("Data").Select
    Range("I10").Select
    ActiveSheet.Paste
    
    Sheets("SortData").Select
    Range("A73:A80").Select
    Selection.Copy
    Sheets("Data").Select
    Range("J10").Select
    ActiveSheet.Pastee

End Sub

Code: Select all

Sub test()
Dim lr As Long, lc As Long
Dim r As Range
Sheets.Add
ActiveSheet.Name = "SortData"
Sheets("Data").Range("A10:J17").Copy Sheets("SortData").Range("A1")
For i = 2 To 10 Step 1
    Cells(1, i).Resize(8, 1).Copy Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Cells(1, i).Resize(8, 1).ClearContents
Next i
lr = Range("A" & Rows.Count).End(xlUp).Row
For Each r In Range("A1:A" & lr)
    If r.Font.Color = 255 Then
        r.ClearContents
    End If
Next r
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
lr = Range("A" & Rows.Count).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column + 1
For i = 9 To lr Step 8
    lc = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    Cells(i, 1).Resize(8, 1).Copy Cells(1, lc)
Next i
Range("A1:J8").Copy Sheets("Data").Range("A10")
Application.DisplayAlerts = False
Sheets("SortData").Delete
Application.DisplayAlerts = True
End Sub

Code: Select all

Cells(1, i).Resize(8, 1).ClearContents