exel macro for a complex problem

[ace_cool_an]

Hi,
I have a file with the following format
FHEADxxyyzz
THEADabcdefgh
TDETLafaaffffff
TTAILsdfsdfdff
THEADasdfdf
TDETLasdas
TTAILasffd
FTAILsffdfdf

I want to format this in such a way that,
a) first I want all FHEADs on one page, all Theads on another n so on.
b) Then I want to covert them using "text to column" providing the field lengths etc.

How can I write a macro for this? Even the first part wud help. Just separate them out into separate sheets

regds,
A

 

[erik.van.geit]

Hello, ace_cool_an,
Welcome to the Board !!!!!

so you want to have kinda sort looking at the 5 first characters ?

kind regards,
Erik

 

[erik.van.geit]

without your answer I'm not sure, but this was intresting enough to create some code
if you want to study this code step through with Function key F8 using a small sample (as you displayed) having a look at
1. your sheet when running "With rng.Offset(0, -1) ..."
2. the "locals" window in the VBEditor when running "Do ... ArrItem = Arr(i, 1)"
3. your workbook when running "For i = 1 To j - 1 Step 2"

Option Explicit
Option Base 1

Sub distribute_data()
'Erik Van Geit
'051122 2148
'group by 5 first characters on new sheets

'EXAMPLE
'START WITH
'ABCDEaaaaa
'EFGHIbbbbb
'ABCDEccccc
'OOOOOddddd
'EFGHIeeeee
'to get 3 new sheets
'sheetname ABCDE    sheetname EFGHI    sheetname OOOOO
'ABCDEaaaaa         EFGHIbbbbb         OOOOOddddd
'ABCDEccccc         EFGHIEEEEE

Dim SH As Worksheet
Dim rng As Range
Dim LR As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim Arr As Variant
Dim ArrItem As String
Dim ArrRowNumbers() As Variant

'EDIT this part
Const col As Integer = 1    'column with data
Const FR As Integer = 1     'first row with data
Const NR As Integer = 5     'how many characters to look at
Set SH = ActiveSheet

If Cells(Rows.Count, col) <> "" Then LR = Rows.Count Else LR = Cells(Rows.Count, col).End(xlUp).Row
Set rng = Range(Cells(FR, col), Cells(LR, col))

Columns(col).Insert Shift:=xlToRight

    With rng.Offset(0, -1)
    .FormulaR1C1 = "=LEFT(RC[1]," & NR & ")"
    .Resize(.Rows.Count, 2).Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:= _
    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    .Value = .Value
    Arr = .Value
    End With

i = 1
j = 1
    Do
    ArrItem = Arr(i, 1)
    k = i
        On Error Resume Next 'avoids bug at the end of the loop "Arr(i, 1)" when i > UBound(arr)
        Do
        i = i + 1
        Loop While ArrItem = Arr(i, 1)
        On Error GoTo 0
            ReDim Preserve ArrRowNumbers(j + 1)
            ArrRowNumbers(j) = k + FR - 1
            ArrRowNumbers(j + 1) = i - 1 + FR - 1
            j = j + 2
            
    Loop Until i > LR
Columns(col).Delete
  
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

    For i = 1 To j - 1 Step 2
    Sheets.Add after:=Sheets(Sheets.Count)
        With ActiveSheet
        .Name = Left(SH.Cells(ArrRowNumbers(i), col), NR)
        SH.Range(SH.Cells(ArrRowNumbers(i), col), SH.Cells(ArrRowNumbers(i + 1), col)).Copy .[A1]
        End With
    Next i

With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With

End Sub

does this help ?

kind regards,
Erik