Text to Columns macro

A

alpercalik

New Member
Joined
Sep 12, 2007
Messages
31
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
 
Sort by date Sort by votes
Ok i think i got it.

Hopefully i guess that no codename contains this character: "^"

Try this, if possible with older mails also to get various results:
Code: 
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))
            Select Case Mid(CStr(Cells(i, 1)), m, 1)
            Case " "
                If Mid(CStr(Cells(i, 1)), m, 3) = " * " Then
                    splitTXT = "^"
                    m = m + 2
                    GoTo Skip
                End If
                If Mid(CStr(Cells(i, 1)), m + 2, 1) <> " " Then
                    If Mid(CStr(Cells(i, 1)), m + 3, 1) <> " " Then
                        If Mid(CStr(Cells(i, 1)), m + 4, 1) <> " " Then
                            splitTXT = "^"
                            GoTo Skip
                        End If
                    End If
                End If
                splitTXT = " "
Skip:
            Case Else: splitTXT = Mid(CStr(Cells(i, 1)), m, 1)
            End Select
            
            NewTxt = NewTxt & splitTXT
        Next m
        NewTxt = Trim(Mid(NewTxt, 3))
        Cells(i, 1) = NewTxt
    Next i
    Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="^"
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
 
Upvote 0

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
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.
Click to expand...

Thanks for the idea. It worked fine but FH 42T B splitted in another cell, but i can adjust it in another macro. The main problem left here is the format of the paste, after using this commands in a macro i tried to use for another code list. I cleared the sheet and pasted the new list but it splitted the whole list with * and empty cells between the codes. The only way i found is to close the sheet and open it again. It seems like this ;



Any way of preventing this format change of paste? Cause it will be useless if i close-open at every code list.
 
Upvote 0
Ok i think i got it.

Hopefully i guess that no codename contains this character: "^"

Try this, if possible with older mails also to get various results:
Code: 
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))
            Select Case Mid(CStr(Cells(i, 1)), m, 1)
            Case " "
                If Mid(CStr(Cells(i, 1)), m, 3) = " * " Then
                    splitTXT = "^"
                    m = m + 2
                    GoTo Skip
                End If
                If Mid(CStr(Cells(i, 1)), m + 2, 1) <> " " Then
                    If Mid(CStr(Cells(i, 1)), m + 3, 1) <> " " Then
                        If Mid(CStr(Cells(i, 1)), m + 4, 1) <> " " Then
                            splitTXT = "^"
                            GoTo Skip
                        End If
                    End If
                End If
                splitTXT = " "
Skip:
            Case Else: splitTXT = Mid(CStr(Cells(i, 1)), m, 1)
            End Select
            
            NewTxt = NewTxt & splitTXT
        Next m
        NewTxt = Trim(Mid(NewTxt, 3))
        Cells(i, 1) = NewTxt
    Next i
    Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="^"
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
Click to expand...

Here is the output of the macro ;



It still creates empty cells. And i realised that at some code there are spaces at he end of the code like "MEDHCM(space)(space)(space)" It may be 2-3 or 5 spaces. If we can get rid of these spaces and empty cells it would be perfect. The exact output i'm trying to get of the list is show below ;

 
Upvote 0
try
Code: 
Sub test()
Dim a, i As Long, ii As Byte, b(), x
a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Value
ReDim b(1 To UBound(a,1), 1 To 4)
For i = 1 To UBound(a,1)
   x = Split(WorksheetFunction.Trim(a(i,1)))
   If UBound(x) > 0 Then
      If UBound(x) > 3 Then
         b(i,1) = x(0) : b(i,2) = x(1)
         For ii = 2 To UBound(x) - 1 : b(i,3) = b(i,3) & " " & x(ii) : Next
         b(i,3) = LTrim(b(i,3)) : b(i,4) = x(UBound(x)) 
      Else
         For ii = 0 To UBound(x) : b(i,ii+1) = x(ii) : Next
      End If
   Else
      b(i,1) = x(0)
   End If
Next
Range("b1").Resize(UBound(b,1), 4).Value = b
End Sub
 
Upvote 0
Right, typo

It should read as Else

That line is missing ":"

For ii = 0 To UBound(x) : b(i,ii+1) = x(ii) : Next

Previous code has been edited
 
Upvote 0
Ahhh,
I've read back your sample and the result should be devided into 5 cells..
Code: 
Sub test()
Dim a, i As Long, ii As Byte, b(), x
a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Value
ReDim b(1 To UBound(a,1), 1 To 5)
For i = 1 To UBound(a,1)
   x = Split(WorksheetFunction.Trim(a(i,1)))
   If UBound(x) > 0 Then
      If UBound(x) > 4 Then
         b(i,1) = x(0) : b(i,2) = x(1)
         For ii = 2 To UBound(x) - 2 : b(i,3) = b(i,3) & " " & x(ii) : Next
         b(i,3) = LTrim(b(i,3)) : b(i,4) = x(UBound(x)-1) : b(i,5) = x(UBound(x))
      Else
         For ii = 0 To UBound(x) : b(i,ii+1) = x(ii) : Next
      End If
   Else
      b(i,1) = x(0)
   End If
Next
Range("b1").Resize(UBound(b,1), 5).Value = b
End Sub
 
Upvote 0
Ahhh,
I've read back your sample and the result should be devided into 5 cells..
Code: 
Sub test()
Dim a, i As Long, ii As Byte, b(), x
a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Value
ReDim b(1 To UBound(a,1), 1 To 5)
For i = 1 To UBound(a,1)
   x = Split(WorksheetFunction.Trim(a(i,1)))
   If UBound(x) > 0 Then
      If UBound(x) > 4 Then
         b(i,1) = x(0) : b(i,2) = x(1)
         For ii = 2 To UBound(x) - 2 : b(i,3) = b(i,3) & " " & x(ii) : Next
         b(i,3) = LTrim(b(i,3)) : b(i,4) = x(UBound(x)-1) : b(i,5) = x(UBound(x))
      Else
         For ii = 0 To UBound(x) : b(i,ii+1) = x(ii) : Next
      End If
   Else
      b(i,1) = x(0)
   End If
Next
Range("b1").Resize(UBound(b,1), 5).Value = b
End Sub
Click to expand...

Should i insert this code into Ktab's code(if yes where between?) or it will be performed as another macro?
 
Upvote 0
Ahhh,
I've read back your sample and the result should be devided into 5 cells..
Code: 
Sub test()
Dim a, i As Long, ii As Byte, b(), x
a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Value
ReDim b(1 To UBound(a,1), 1 To 5)
For i = 1 To UBound(a,1)
   x = Split(WorksheetFunction.Trim(a(i,1)))
   If UBound(x) > 0 Then
      If UBound(x) > 4 Then
         b(i,1) = x(0) : b(i,2) = x(1)
         For ii = 2 To UBound(x) - 2 : b(i,3) = b(i,3) & " " & x(ii) : Next
         b(i,3) = LTrim(b(i,3)) : b(i,4) = x(UBound(x)-1) : b(i,5) = x(UBound(x))
      Else
         For ii = 0 To UBound(x) : b(i,ii+1) = x(ii) : Next
      End If
   Else
      b(i,1) = x(0)
   End If
Next
Range("b1").Resize(UBound(b,1), 5).Value = b
End Sub
Click to expand...

Should i insert this code into Ktab's code(if yes where between?) or it will be performed as another macro?
Click to expand...

It didnt work too, it created a lot of cells with *'s in it and didnt split them as i wished. Maybe i couldnt be clear, thats why i'm posting the source code list as i got from email ;



As you can see there are 5 codes in every cell ; A1 has 5 codes,A2 has 5 codes etc... but what i want to get is splitting those codes to a separate cells as i showed below ;



With no stars and no blanks before and after every codes. Hope this is clear now.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Macro Works for Me but Not Others
Replies
3
Views
2K
Fluff
Fluff
B
  • Question Question
3 three CASCADING DATA VALIDATION (CATEGORY, DESCRIPTION and MODEL) PLEASE HELP ! ! ! ! ! ! Thank you and GOD BLESS....
2
Replies
14
Views
7K
Brixton11
B
B
  • Question Question
Updating Excel Chart range via vba/macros
Replies
1
Views
2K
Derek Brown
D

Forum statistics

Threads
1,223,227
Messages
6,170,849
Members
452,361
Latest member
d3ad3y3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top