sort and extract text to another excel file

[Ethen5155]

Hi,

i have a large excel file contains about 100,000 rows of data on one column and need to be sorted and filtered to another file with three columns.

The main file contains one column with those data, and i need to extract them to another file as shown below


https://www.excelforum.com/attachments/excel-programming-vba-macros/615269d1552474933-sort-and-extract-text-to-another-excel-file-1.png

i have attached two files for before and after.

There some points if possible to be maintained:

1- Save the extracted result to another excel file at the same path.

2- Save the result file after extracting every 5000 rows to avoid crashing file because of the huge number of data as i mentioned previously, and preferred to add progress bar as this

https://www.excelforum.com/attachments/excel-programming-vba-macros/615273d1552475439-sort-and-extract-text-to-another-excel-file-2.png

and to be saved with name like this sequence: 1-5000 / 5001-10000 / 10001-15000 .....etc.



I'm sorry if i make it long and little bit hard but i appreciate if someone can help or give me a little hint because i'm in a big trouble with that file https://www.excelforum.com/images/smilies/frown.gif.


Thanks in Advance

Cheers

Cross Posted link: Here (https://www.excelforum.com/excel-programming-vba-macros/1268214-sort-and-extract-text-to-another-excel-file.html#post5082133)

[Ethen5155]

Solved Here (https://www.excelforum.com/excel-programming-vba-macros/1268214-sort-and-extract-text-to-another-excel-file.html)



Sub test() Dim a, i As Long, ii As Long, temp
Application.ScreenUpdating = False
Sheets.Add Sheets(1)
With Sheets("sheet1").Cells(1).CurrentRegion.Offset(1)
For i = 1 To .Rows.Count Step 5000
a = .Rows(i).Resize(5000).Value
ReDim Preserve a(1 To UBound(a, 1), 1 To 3)
With CreateObject("VBScript.RegExp")
.Pattern = "^(.*?)<i>(.*?)</i><br>(.*)"
For ii = 1 To UBound(a, 1)
temp = a(ii, 1)
If .test(temp) Then
a(ii, 1) = .Replace(temp, "$1")
a(ii, 2) = .Replace(temp, "$2")
a(ii, 3) = .Replace(temp, "$3")
End If
Next
End With
With Sheets(1).Cells(1).Resize(, 3)
.EntireColumn.Clear
.Value = [{"vocabulary","lexicon","definition"}]
.Rows(2).Resize(UBound(a, 1)).Value = a
.Parent.Name = i & "-" & i + 5000 - 1
.Parent.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
i & "-" & i + 5000 - 1 & ".xls", 56
ActiveWorkbook.Close False
End With
Next
End With
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub