Text to Columns macro

[alpercalik]

Hello,
First of all i have to mention that i'm not a coder guy so excuse me if i'm no good in explaining the problem.

What i'm trying is to convert texts into columns. I constantly have an email containing short codes about my business and each code has a special meaning. So i need to convert these codes and lookup in my database. Here is an example of the source file in email.

V MFACTBEL 04-TLV * FH 42T B * USAFEP * FH42T440
V * MEDHCM EPAH342 EUDRPA1 * UDFSUB * EU5SCR
V FROCALC * TYPE-FH * V2514 * ULIVING * SOUNDPLU
V * AIRFLPAC * EC-REG * L405A71 * R690A71 * LNGTUR
V * MIRCOMF * CBL2-BA3 * 1DAYEC * TUR-MSP LFUEL
V RFUEL * WL-ST * UAXLE * TEXTILE * TTRCON77
V * ESH-LEFT * UDFP * 4*2 * TRACTOR CONC-BAS
V BRAND-V VERSION2 * RC-SMOOT * VAL-BAS3 * T-PFLAT
V * TC-LONGD VERS-BAS * GCW44.0 ENG-VE13 * UEGR
V * FAL7.1 * RAL13 * STWPOS-L FFL1295 FAP3040
V RAP6840 * VW2600 * CHH-MED * VH4.0 * NR-80EC
V * UADR * D13A440 ETOR2250 UENG-GEN VOLENG
V * OILS-PL * FUELSEC2 LFUEL405 RFUEL690 FUELTS71
V FTANK-AL * UXFUEL TNK-DUAL * FCAP-L * FUELTFIL
V UFUFIWH * UFUELFP * AF-E * TURB-B * EXHP-SAC
V MUF-HOR EXD-LEFT * EXSH-ST UEXSTACK * EBR-VEB
V * UEBRAS * EM-EC06B * ADTL60 * RAG-ADBL * ADTM-PL
V * ADTP-ML * UADTR * ADTS71 * EAS-SCR * ACL1ST-S
V * AIRIN-HI AIRRI-D * CCV-O * COOLC48 RADI-WID
V * BUGNET CHOSE-RU ATNK-GEN UATNKRUB FAN-VISE
V * SPEED90 * UACC * USPEEDDU USPLIMS * CRUISEC
V ENGPROT UPTOM UPTOR * EOBD-BAS UISD
V 24V * 2BATT225 * BATTD128 * BBOX-L BBOXC-BA
V TAS-ANA * 24ALT-XB * UALTTR * SMCONT * EST-AID
V * HL-ASYMR * IDLAMP * LOWB-STD * RLIGHT-W * HL-BASIC
V * UHLADJ * URPLCR TL-BAS TLB-BAS * INLI-BAS
V * MARKL-SR * UFLASHL * FOGL-WC * DRIVL2EC * UWPREBOC
V * WL-TA1W * UWARNLIG * USPOTP * TD-BAS * UBULBKIT
V * ULAMPIN * HORN-ELS * HORN-JER * UHLCLEAN MAINSW-M
V * SWS-R * DOL24S12 * UALARMB * IMMOBIL DETECT-S
V * ULSS * ULOADIND * UELCEPK CIRCP-F * AUXSW-6
V * RTOLL-PK DIFL-TUR DISL-NUM * INST-HIG * MSW-BAS
V * TEMP-AMB TEMP-TRA * UGAUGEAM * SPG-KM SI-GRAF
V 1DAY-STD CALI-EC * UBUPALAR * AUD-MED2 * UAMPL
V * UBUPMON * UPHONE * TRANSF-H * ANT-CBPK TWEETER
V * SPK-DDR * UCOMEQ * UFMS UTIS UKEYB
V * CS43B-OR * CLUT-BAS * UTRAPACK VT2514B * UAPF
V MECHTRAN TRAN-V * UAMSO * TRAP-BAS GSS-SRC
V PSM-GKN PROP-STD UPSBRKT1 UPSBRKT2 UPSBP1
V UPSBP2 PROPS-M UPLF UPLS PLM1800
V MPRO-FXS SRED-V * RSS1344C GENRAX RACAS-CA
V * RAT2.85 DL-FULL UPTOTRA * UPTOTR * UPTER
V UPTOENGR * UEPTT * UPTOFLYW UPTOF * TC-MWO
V * UCOOLPTO BSYS-EBS BRAD-BAS * BRAKE-DV FBRA-D43
V BF-DILW * SBCC-B * AUXPARK BRADJ-A DBRDUST
V RBRA-D41 BR-DILW * BRCYL-LO BRV-V1 BRCYL-V1
V ATANK-V1 ASCOP120 * AIRDRY-E * 2COM1080 SIL-BRV
V * FBREG-E * LOADSV TRBRAKE1 * TRBR-EBS * TCP-BMC
V TBH-COL TEC-DET TREL7-7 TECT-SBP * TBC-EC
V * UTRACON * UTABS UHOSEH * URETARD * EBS-MED
V * ABS-EBS ABSM-GEN FATYPE71 FRAX-UNI FAA10
V FA-LOW STW-D450 STG26.2 * UPSCOOL * PSS-SING
V RAA11 * RAD-A4 * UBSR * UTAD UPAXLE
V UTAXLE URSTS URSTL * URALIM * UWCAP
V * UFRACLOS RF-TAPER * FRAME65 * FRAMELOW * RFL825
V * ULINER * SWCP-T * SPWCD-EC SPWCA-B * UGUARD
V * URUP * SUP-BAS * FUP RSAP-BAS * FST-PAR
V * RST-AIR2 FSS-LEAF RSS-AIR FRH-180 * UFAS
V RRH-180 UWEDGE * RSHABS * FSTAB * RSTAB1
V * SUSPL-EC * WTD-DUAL * SPWT-F WSTUD-S WTF-D335
V WMF-ST * WDF900 * WTDF22.5 WTD-D335 WMD-ST
V * WDD900 * WTDD22.5 * UTFSEAL * UTDSEAL * TF315-60
V * TMF-MICH * TF-ENVI * TTF-RIB1 * TD315-60 * TMD-MICH
V * TD-BASIC * TTD-LUG4 WPRING-P * INFLAHOS * UDECALTP
V * UGAUGETP * UTIREPM * 1616BLUE * PAICS-B CAB-WIDE
V * L2H2 * CABS-MEC * CTILTP-M * GR-STD * USIDESTP
V FMUDE-B * LOCK-MRP * WLIFT-EB * RHATCH * LUGOP-BS
V MIRR12C1 AMIR-WB * UAMIRF * REFL-EC * UREFS
V * UEXTRIM * GLAS-TIN * UAWINDR * UAWINDS MIR-ELOP
V AMIR-S30 * EMBL-MO * ROS-IL * CABSIGN * UROOFSIG
V TRIM-TX1 * CITC-IBL DPAN-IAT CPAN-MF * DST-CF1
V * PST-STD2 SEAT-VOL SUPH-TEX * UARMREST * MAT-GREY
V * MAT-INS * XINS-CAB * MAT-RUB * MATT-PRE * BUNK70T
V * UOFFICE * UGUARDW * GUARD-HL * BUMP-P * UBUMPSP
V * FMUD-AS * CU-ECC * PH-ENGCA * UEBHEAT * UWARVEST
V * SAFEKIT * BOTTLEH * DASH-BLU * WRITEPAD * SLCP-LUX
V * DASHB-BX * DASHP-BX * BUNKBOX * UIDLMPSW * USAFETYB
V RSH-RACA * UOBSTOR * UETSBOX CURT-WB * SBD-BLAC
V SBP-BLAC * BEDNET * UAIRBAG SEATBRI * USBPREDS
V * USBPREPS * REF-IC22 * UCOFMAK * UFLARE * CABPT-R1
V ADH-HIGH * ULADDER * SUNV-SMO * ESUNV2P * ISUNF-B
V SUNV-URL * ISUNV-S * AD-ROOF * AD-SIDEL * AD-CHASX
V * UACCBRKT TOWF-NO1 * FIREXT3S * UWRNLAMP * JACK-12T
V * TOOLKIT * UTBL * UTBR PUBL-TUR TELECARD
V * USIGNSWC USIGNS DIMPLATE LANG-TUR * CERT-EC
V * SIGN-L SERVM-B WARR300 UTRUSTP * UHPE
V * UHPG * UPSCAT * WHCHOCK2 * FWP0675 * 5WM-LPRO
V * 5WH160 * KPSIZE50 * 5WT-GF RFLI-F * URFCAR
V RMUDF-AS * RFEND-B * RDECK * RAMP-LOW * UTOWMBR
V * UTOWR * ULCHF * UTAIL * ULUBCENT * UCHAINS
V * UHOOKSC PROPCALC * 8EE * WB3800 2495MM
V 6000MM 3700MM * STG-LR * FACT-BEL

Whenever i copy&paste all these codes, every 5 codes stays in a cell instead of 5 different cells. So i perform "text to columns" function to get every 5 codes in a different cell. If i do it manually i can perfectly get what i want if i choose "fixed with" option. After that i created a macro to make this work fastly and easily. At first it was working great but i tried it with codes in the following days emails and saw that it was failing to create a breakline at the desired place. Since the codes may vary, the textlengths were increasing or decreasing so it was failing to break in the right position. Then i tried to use its delimited option. This time i was choosing "space" and "star(other)" but this was failing too because of there were 2 codes, 1 of them containing star,1 of them containing space in it. And text to columns function was separating those too.
I need help on this. Thans in advance.
Here is the code i got from VB of my macro :

Sub shape_only()
'
' shape_only Macro
' Macro recorded 12.09.2007 by mwtr065
'

'
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(1, 1), Array(3, 1), Array(14, 1), Array(15, 1), _
Array(26, 1), Array(27, 1), Array(38, 1), Array(39, 1), Array(50, 1), Array(51, 1)), _
TrailingMinusNumbers:=True
Range("A:A,B:B,D:D,F:F,H:H,J:J").Select
Range("J1").Activate
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub

 

[ktab]

Could you provide an example of, let's say the first 7 datarows, as desired result?

 

[alpercalik]

MFACTBEL 04-TLV FH 42T B USAFEP FH42T440
MEDHCM EPAH342 EUDRPA1 UDFSUB EU5SCR
FROCALC TYPE-FH V2514 ULIVING SOUNDPLU
AIRFLPAC EC-REG L405A71 R690A71 LNGTUR
MIRCOMF CBL2-BA3 1DAYEC TUR-MSP LFUEL
RFUEL WL-ST UAXLE TEXTILE TTRCON77

This the result i need to have. With no stars and the letter "v". Every code has its cell,so i can run my lookup formula in the worksheet properly.

 

[ktab]

And you need each line in one cell not broken to columns right?
Like
MFACTBEL 04-TLV FH 42T B USAFEP FH42T440 is ALL included in cell a1
Or:
a1:MFACTBEL
b1:04-TLV FH 42T B
c1:USAFEP
d1:FH42T440 e.c.t.

 

[alpercalik]

It will be :

a1:MFACTBEL
b1:04-TLV
c1:FH 42T B (This one is the problematic one if i choose delimited function)
d1:USAFEP
e1:FH42T44
a2:MEDHCM
b2:EPAH342
c2:EUDRPA1
d2:UDFSUB
e2:EU5SCR
.
.
.
.
7c:4*2 (This one is the other problematic one because of it contains star)

 

[ktab]

I have something like a solution here, the only problem occurs at the example space appears in the code, like your c1 cell.
Try it at first to check if it somehow do what you need and we will look for the other too. Just a question. Is there a possibility that a code provided could be only 2 chr or 3 chr long?
If there is no such possibility then the sting FH 42T B we can make it not to be cutted to FH and 42T and B.

Option Explicit

Sub shape_only()
    Dim i As Long, LR As Long, m As Long, splitTXT As String, NewTxt As String
    
    LR = LastRow(ActiveSheet)
    
    For i = 1 To LR
        NewTxt = ""
        For m = 1 To Len(Cells(i, 1))
            If Mid(CStr(Cells(i, 1)), m, 1) = "*" Then
                splitTXT = ""
            Else: splitTXT = Mid(CStr(Cells(i, 1)), m, 1)
            End If
            NewTxt = NewTxt & splitTXT
        Next m
        Cells(i, 1) = NewTxt
    Next i
    With Columns(1)
        .TextToColumns Cells(1, 1), DataType:=xlDelimited, Space:=True
        .Delete
    End With
End Sub

Public Function LastRow(Worksheet_name As Worksheet, Optional Column_Num As Long = 1) As Long
    Dim i As Long
    
    On Error GoTo Set_i
    
    i = Worksheet_name.Columns(Column_Num).Find("*", searchdirection:=xlPrevious).Row
    
i_Value:
    LastRow = i
    Exit Function
Set_i:
    i = 1
    GoTo i_Value
End Function

 

[alpercalik]

First of all it creates some blank cells between some codes which i didnt want to have.Secondly i realised that the star between 4*2 is gone, actually i prefer that star to stay there. And last of all unfortunately it is not possible to make these codes 2 or 3 chr long.

 

[ktab]

Blank cells meaning blank chr like " " ? This can be removed with trim. No problem. The star "*" is trully gone at 4*2 due to the procedure of removing "*" so texttocolumns is for space only. Last i did no mean to make codes 2 or 3 long, I was asking if you recieve codes that are 2 or 3 long. If you don't then it's easy to understand that if macro sees a code like FH 42T B we will fix it as not to split it into FH,42T,b but maintain code format of FH 42T B as one in cell.
As i will be leaving sortly, and in case noone else advise you, i'll get back within 4 hours.

 

[alpercalik]

Ok i misunderstood, there is no more 2 or 3 chr long codes except FH 42T B . It is the only one.
What i mean from blank cells is the empty cells like ;

 

[rahul_gundecha]

Hi,
I don't know i am making sense or not but i found the solution to your problem for all the rows you mentioned except the first row.

Please follow below steps:
Use find and replace utlity (Ctrl+H)
1) Find what: (space) ~*(space)
Replace with: |
2) Find what: (space)
Replace with: |
3) Data->Text to column wizard->Delimited->Now select delimiter as:"|" (without quotes) and click on finish.
Please let me know whether my suggestion is right or wrong.