VBA: Simple data arrangement issue

[icesanta]

Please help me with this simple data arrangement issue.
If data is found in the cell then only the VBA will work.
I have around 50 thousand rows.
I have the data in sheet 1 and need to get the data in sheet 2 as shown in the image.
Thanks in advance.

 

[Peter_SSs]

Two things that might help in the future:

1. Update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

2. MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.


Assuming that Sheet2 exists in your workbook but is empty, try this.

Sub Rearrange()
  Dim a As Variant, b As Variant, Bits As Variant
  Dim i As Long, j As Long, k As Long, c As Long, uba2 As Long
  
  With Sheets("Sheet1")
    a = .Range("A1").CurrentRegion.Value
    uba2 = UBound(a, 2)
  End With
  ReDim b(1 To Rows.Count, 1 To uba2)
  For i = 1 To UBound(a)
    Bits = Split(a(i, 2), ";")
    For c = 0 To UBound(Bits)
      k = k + 1
      b(k, 1) = a(i, 1): b(k, 2) = Bits(c)
      For j = 3 To uba2
        b(k, j) = a(i, j)
      Next j
    Next c
  Next i
  With Sheets("Sheet2").Range("A1").Resize(k, uba2)
    .Value = b
    .Columns.AutoFit
  End With
End Sub

 

[bebo021999]

Option Explicit
Sub test()
Dim Lr&, i&, j&, k&, cell As Range, s, arr()
With Sheets("Sheet1")
Lr = .Cells(Rows.Count, "A").End(xlUp).Row
ReDim arr(1 To 65000, 1 To 8)
    For Each cell In .Range("B3:B" & Lr)
        s = Split(cell, ";")
        For i = 0 To UBound(s)
            k = k + 1
            For j = -1 To 6
                arr(k, j + 2) = cell.Offset(0, j).Value
                If j = 0 Then arr(k, j + 2) = s(i)
            Next
        Next
    Next
End With
With Sheets("Sheet2")
    Sheets("Sheet1").Range("A2:H2").Copy .Range("A2")
    .Range("A3").Resize(k, 8).Value = arr
    .Range("A3").Resize(k, 8).Borders.LineStyle = xlContinuous
End With
End Sub

BEFORE:

Book1
	A	B	C	D	E	F	G	H
1
2	Group	Name	Subject	Marks	P	C	O	C
3	Green	David;Matt	Matchs	-10	a	fg	u	sd
4	Green	Golia	Matchs	-20	b	ghj	j	adf
5	Red	Golia	Matchs	-20	c	fg	g	h
6	Blue	David;Matt;Henry	English	0.0001	f	ghg	g	dfg
7	Blue	Danish	English	-0.0002	e	gfh	df	sdf
Sheet1

AFTER:

Book1
	A	B	C	D	E	F	G	H
2	Group	Name	Subject	Marks	P	C	O	C
3	Green	David	Matchs	-10	a	fg	u	sd
4	Green	Matt	Matchs	-10	a	fg	u	sd
5	Green	Golia	Matchs	-20	b	ghj	j	adf
6	Red	Golia	Matchs	-20	c	fg	g	h
7	Blue	David	English	0.0001	f	ghg	g	dfg
8	Blue	Matt	English	0.0001	f	ghg	g	dfg
9	Blue	Henry	English	0.0001	f	ghg	g	dfg
10	Blue	Danish	English	-0.0002	e	gfh	df	sdf
Sheet2

 

[icesanta]

Thank you, Bebo. Can I get the rows sorted in descending order of marks by subject (one below another)?
And get the least ten in sheet3 in descending order of marks by subject (one below another)?

 

[Peter_SSs]

Did you try the other code?
For large data it should be quicker and you did say that you had around 50,000 rows.

Can I get the rows sorted in descending order of marks by subject (one below another)?

Like this?

Sub Rearrange_v2()
  Dim a As Variant, b As Variant, Bits As Variant
  Dim i As Long, j As Long, k As Long, c As Long, uba2 As Long
 
  With Sheets("Sheet1")
    a = .Range("A1").CurrentRegion.Value
    uba2 = UBound(a, 2)
  End With
  ReDim b(1 To Rows.Count, 1 To uba2)
  For i = 1 To UBound(a)
    Bits = Split(a(i, 2), ";")
    For c = 0 To UBound(Bits)
      k = k + 1
      b(k, 1) = a(i, 1): b(k, 2) = Bits(c)
      For j = 3 To uba2
        b(k, j) = a(i, j)
      Next j
    Next c
  Next i
  Application.ScreenUpdating = False
  With Sheets("Sheet2").Range("A1").Resize(k, uba2)
    .Value = b
    .Columns.AutoFit
    .Sort Key1:=.Columns(3), Order1:=xlAscending, _
          Key2:=.Columns(4), Order2:=xlDescending, _
          Header:=xlYes
    .Parent.Activate
  End With
  Application.ScreenUpdating = True
End Sub

And get the least ten in sheet3 in descending order of marks by subject (one below another)?

You would need to explain that more fully and/or give some small sample data and the results you mean by this.

 

[icesanta]

Thank you.
In column B I have names and in C I have subjects
I want to sort the marks data in descending order considering the name and subject both as in the image.
I want to check the lowest to highest in each subject and want to know their names but only the lowest 10.

 

[Peter_SSs]

So, did my latest code produce the Sheet2 results that you wanted? (No point in proceeding if the first part is not what you want)

 

[icesanta]

My apologies.
As there are more than 50 thousand rows so it is not easy for me to know the lowest 10 of say, David or Goliath. There are hundreds of names.
And I want to know the lowest 10 of each name in each subject.
Hope I am clear now.

 

[bebo021999]

For testing purpose, it's better if you can re-post new version, with more rows, to display the lowest 10.

 

[Peter_SSs]

As there are more than 50 thousand rows so it is not easy for me to know the lowest 10 of say, David or Goliath. There are hundreds of names.
And I want to know the lowest 10 of each name in each subject.
Hope I am clear now.

No, it is not clear as you did not address my last question..

So, did my latest code produce the Sheet2 results that you wanted? (No point in proceeding if the first part is not what you want)