custom sort according to header in each sheet

hello frds ,

i have four sheets ,

all four sheets have headers in a1 , b1 , c1 , d1

all four headers has custom sort order , which is define in sheet(ORDER)

appearance of this headers in all four sheets are in differently
sheet1 : PLANETS MONTHS DAYS COLOR
sheet2 : COLOR DAYS MONTHS PLANETS
sheet3 : DAYS COLOR PLANETS MONTHS
sheet4 : MONTHS PLANETS COLOR DAYS

all four sheets needed to be sorted out in order mention in sheet(order)

just for example , i have attach small sample file .

i would like to custom sort this sheets with vba , rather manually , coz we have ard 75 sheets like this

Try this:-

Sub MG28Nov12
Dim rng As Range, n As Long, nn As Long
Dim Dn As Range, c As Long
Dim RngAc As Range, Ac As Range
Dim Dic As Object, Q As Variant
Dim Shts As Variant, Sh As Variant, G As Variant
 
Shts = Array(1, 2, 3, 4)
For Each Sh In Shts
   Set Dic = CreateObject("Scripting.Dictionary")
       Dic.CompareMode = 1
       Set RngAc = Sheets("Order").Range("A1:D1")
        For Each Ac In RngAc
            If Not Dic.exists(Ac.Value) Then
                Set Dic(Ac.Value) = CreateObject("Scripting.Dictionary")
            End If
            With Sheets("Order")
                Set rng = .Range(.Cells(Ac.Offset(1).Row, Ac.Column), .Cells(Rows.Count, Ac.Column).End(xlUp))
            End With
            For Each Dn In rng
                If Not Dic(Ac.Value).exists(Dn.Value) Then Dic(Ac.Value).Add (Dn.Value), 0
            Next Dn
        Next Ac

Set RngAc = Sheets(Sh).Range("A1:D1")
    For Each Ac In RngAc
       With Sheets(Sh)
        Set rng = .Range(.Cells(Ac.Offset(1).Row, Ac.Column), .Cells(Rows.Count, Ac.Column).End(xlUp))
       End With
       
        For Each Dn In rng
                If Dic(Ac.Value).exists(Dn.Value) Then
                Dic(Ac.Value).Item(Dn.Value) = Dic(Ac.Value).Item(Dn.Value) + 1
                End If
        Next Dn
 
c = 1
    For Each G In Dic(Ac.Value)
        For nn = 1 To Dic(Ac.Value).Item(G)
            c = c + 1
            Sheets(Sh).Cells(c, Ac.Column) = G
        Next nn
    Next G
Next Ac
Next Sh
MsgBox "Run"
End Sub

Regards Mick

wonderful sir , works like magic ,

Thanks alot much for taking the time to help with my project.

sir ,

only small question related to same vba ,
i just added 5 th column as price ,
but i dont want to sort that ,
would like to expand selection after sorting those 4 columns .

Please explain, what you mean, I don't understand !!!

would like to expand selection after sorting those 4 columns .

4 columns we are custom sorting .,

5th column price , we are expanding the sortment ,

just an example of i am trying to say

EXPAND SELECTION.JPG

SHEET2.jpg

this is how i am doing it manually ,
selecting 5 columns to sort ,
but only giving 4 columns for custom sort

also i have attach excel .
for example if you search any number on 5th column in all 4 sheets , its corresponding values are same ,

Are you saying that you would like the number in column "E" that relates to the Unique row of data in the same row, columns "A to D", to be placed against the same Combinations after the sort.

yes sir

exactly ,

Try this:-
Its a bit slow approx 30Secs, if too slow, I'll rewrite using arrays ???

Sub MG29Nov00
'Range Code
Dim Rng As Range, n As Long, nn As Long
Dim Dn As Range, c As Long, Stg As String
Dim RngAc As Range, Ac As Range
Dim Dic As Object, Q As Variant
Dim Shts As Variant, Sh As Variant, G As Variant
Dim nDic As Object
Dim t
t = Timer
Shts = Array(1, 2, 3, 4)
For Each Sh In Shts
   Set Dic = CreateObject("Scripting.Dictionary")
       Dic.CompareMode = 1
       Set RngAc = Sheets("Order").Range("A1:D1")
        For Each Ac In RngAc
            If Not Dic.Exists(Ac.Value) Then
                Set Dic(Ac.Value) = CreateObject("Scripting.Dictionary")
            End If
            With Sheets("Order")
                Set Rng = .Range(.Cells(Ac.Offset(1).Row, Ac.Column), .Cells(Rows.Count, Ac.Column).End(xlUp))
            End With
            For Each Dn In Rng
                If Not Dic(Ac.Value).Exists(Dn.Value) Then Dic(Ac.Value).Add (Dn.Value), 0
            Next Dn
        Next Ac

    Set RngAc = Sheets(Sh).Range("A1:D1")
    Set nDic = CreateObject("Scripting.Dictionary")
       nDic.CompareMode = 1
      'Ref#
  With Sheets(Sh)
        Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
    End With
        For Each Dn In Rng
            With Application
                Stg = Join(.Transpose(.Transpose(Dn.Resize(, 4).Value)))
            End With
            nDic.Item(Stg) = Dn.Offset(, 4)
       

       Next Dn
    'Ref#
For Each Ac In RngAc
       With Sheets(Sh)
        Set Rng = .Range(.Cells(Ac.Offset(1).Row, Ac.Column), .Cells(Rows.Count, Ac.Column).End(xlUp))
       End With

        For Each Dn In Rng
                If Dic(Ac.Value).Exists(Dn.Value) Then
                Dic(Ac.Value).Item(Dn.Value) = Dic(Ac.Value).Item(Dn.Value) + 1
                End If
        Next Dn

c = 1
    For Each G In Dic(Ac.Value)
        For nn = 1 To Dic(Ac.Value).Item(G)
            c = c + 1
            Sheets(Sh).Cells(c, Ac.Column) = G
        Next nn
    Next G
Next Ac
'Ref# Add
 With Sheets(Sh)
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
 End With
        For Each Dn In Rng
            With Application
                Stg = Join(.Transpose(.Transpose(Dn.Resize(, 4).Value)))
            End With
            Dn.Offset(, 4) = nDic.Item(Stg)
       Next Dn

'Ref# Add
Next Sh
MsgBox Timer - t
End Sub

Regards Mick

sorry file above 1 mb , so cant upload here , so sending this two links

https://www.dropbox.com/s/c7boknn7zs...FTER.xlsx?dl=0

https://www.dropbox.com/s/m6h17d05dv...FORE.xlsx?dl=0

Try this:-
NB:- Your sheet lists appear to be all the combination of the data on sheet "Order", But mixed up and in various Header order.
The code now checks each line against a Data set of the appropriate combinations, Replacing the results in order on the sheet, as found , and with the appropriate number, added in column 6.
Hope this is what you want !!!!

Sub MG01Dec40
'Mg 1/12/14
Dim Ray(1 To 5) As Variant, c As Long
Dim AcRng As Range, Dn As Range
Dim R1 As Long, R2 As Long, R3 As Long, R4 As Long, R5 As Long
Dim Rng As Range, n As Long, nn As Long
Dim rRay As Variant, DicR As Object, Q As Long
Dim Shts As Variant, Sh As Variant, G As Variant
Dim nDic As Object
Dim nRay As Variant
Dim t
t = Timer
Set AcRng = Sheets("Order").Range("A1:E1")
Set DicR = CreateObject("scripting.dictionary")
DicR.CompareMode = vbTextCompare
    For Each Dn In AcRng
        With Sheets("Order")
            Set DicR(Dn.Value) = .Range(.Cells(2, Dn.Column), .Cells(Rows.Count, Dn.Column).End(xlUp))
        End With
    Next

Shts = Array(1, 2, 3, 4)
For Each Sh In Shts
n = 0
For Each Dn In Sheets(Sh).Range("A1:E1")
    n = n + 1
    Ray(n) = DicR.Item(Dn.Value)
Next Dn

ReDim aRay(1 To UBound(Ray(1)) * UBound(Ray(2)) * UBound(Ray(3)) * UBound(Ray(4)) * UBound(Ray(5)), 1 To 6)
Set nDic = CreateObject("scripting.dictionary")
nDic.CompareMode = vbTextCompare
c = 0
For R1 = 1 To UBound(Ray(1))
    For R2 = 1 To UBound(Ray(2))
        For R3 = 1 To UBound(Ray(3))
            For R4 = 1 To UBound(Ray(4))
                For R5 = 1 To UBound(Ray(5))
                 c = c + 1
                 nDic(Ray(1)(R1, 1) & Ray(2)(R2, 1) & Ray(3)(R3, 1) & Ray(4)(R4, 1) & Ray(5)(R5, 1)) = c
                    aRay(c, 1) = Ray(1)(R1, 1)
                    aRay(c, 2) = Ray(2)(R2, 1)
                    aRay(c, 3) = Ray(3)(R3, 1)
                    aRay(c, 4) = Ray(4)(R4, 1)
                    aRay(c, 5) = Ray(5)(R5, 1)
                Next R5
            Next R4
        Next R3
Next R2
Next R1
 
  With Sheets(Sh)
        nRay = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Resize(, 6)
        For n = 1 To UBound(nRay, 1)
            If nDic.exists(nRay(n, 1) & nRay(n, 2) & nRay(n, 3) & nRay(n, 4) & nRay(n, 5)) Then
                Q = nDic.Item(nRay(n, 1) & nRay(n, 2) & nRay(n, 3) & nRay(n, 4) & nRay(n, 5))
                aRay(Q, 6) = nRay(n, 6)
           End If
        Next n
        .Range("A2").Resize(UBound(aRay), 6) = aRay
End With
Next Sh
MsgBox Timer - t
End Sub

Regards Mick

hello sir ,
its 90 % working in right direction ,
but its leaving black cells in between .
if you check my "AFTER" sheet , there is no black cells .

i think vba calculate A1:E1 from order sheet .
but actual order should be
("A1:A10", "B1:B10", "C1:C8", "D1:D13", "E1:E7")
but i am happy with this too , thank you for you help and cooperation

I meant to say, in your sheet "Order" for all data columns, below the cells in each column with Data, there are Blank cells that have something in them, and the code uses the blank cells.
I don't know whats in them but I had the same trouble as you, before I found out what was causing it.
What you need to do is move the whole range to some spare place on the worksheet and then Copy and paste back each individual column of data.
Make sure you only copy the Data in each column.

wow ....prefect ....excellent sir ,

million thanks for your help and guidance

and for trying again and again till you found end result ...