PDA

View Full Version : Help formatting text to columns using VBA



colonna
03-25-2013, 04:37 AM
Hello all,
I have the text bellow , in one cell. And i need to extract different piece of text , to columns.
first column - Model : starts at "Gefundene Artikel für"
second column - displacement : is eighter "H I N T E N" , "V O R N E" or blank
third column - code : Start with EBCXXXXXX
fourth column - Details : Start after EBCXXXX and ends before "Versandkosten".


How can i achive this ????

A big Thank in advance
______________________________________________
"Über uns | Kontakt | Impressum | AGB

STARTHÄNDLER-ANFRAGENHÄNDLER SCHNELL-EINKAUFONLINE-SHOPSPRODUKTIONFAQ

AUTOMOTORRADMTBKARTLKWBAUMASCHINENWINDRÄDER


Benutzername : Passwort : (nur für Händler erforderlich)Passwort vergessen? Probleme beim Login?






Direktsuche nach EBC Art-Nr.:

Mein Warenkorb
Teile: 0
Summe: 0.00 €


Schlüsselnummer: zu 2: zu 3:

Marke: ACAcuraAlfa RomeoAlpinaAroAsia MotorsAston MartinAudiAustinAustin-HealeyAutobianchiBedfordBMWBorgwardBuickCadillacCallowayCaterhamChevroletCh ryslerCitroenDaciaDaewooDaihatsuDodgeEagleFerrariFiatFordFord (USA)FSOGEOGMCHondaHummerHyundaiInfinitiInternationalIsuzuJaguarJeepJensenK iaKTMLadaLamborghiniLanciaLand RoverLandwindLDVLexusLigierLincolnLotusMahindraMaseratiMazdaMercedes-BenzMercuryMiniMitsubishiMorganNissanOldsmobileOpelPeugeotPiaggioPlymouthPo ntiacPorscheRenaultRoverSaabSaturnScionSeatSkodaSmartSsangyongSterlingSubar uSuzukiTataToyotaTriumphTVRVauxhallVolvoVWWartburgZastavaZAZ
Modell: 428 Cabrio (65-74)ACE (95-)ACECA (98-)Cobra MK 4 (90-) Neuen Typ wählen
Gefundene Artikel für AC - 428 Cabrio (65-74) - 7.0

V O R N E

EBC101366 Greenstuff Bremsbeläge (Satz für die kompl. Achse)
deutsche Ausführung
Beläge vorne

Weitere Artikelinfos anzeigen x in den Warenkorb100.96 € (inkl. MwSt)
zzgl. Versandkosten

H I N T E N

EBC101359 Greenstuff Bremsbeläge (Satz für die kompl. Achse)
deutsche Ausführung
Beläge hinten

Weitere Artikelinfos anzeigen x in den Warenkorb81.81 € (inkl. MwSt)
zzgl. Versandkosten

V O R N E

EBC102134 Redstuff Bremsbeläge (Satz für die kompl. Achse)
deutsche Ausführung
Beläge vorne

Weitere Artikelinfos anzeigen x in den Warenkorb114.69 € (inkl. MwSt)
zzgl. Versandkosten

H I N T E N

EBC102128 Redstuff Bremsbeläge (Satz für die kompl. Achse)
deutsche Ausführung
Beläge hinten

Weitere Artikelinfos anzeigen x in den Warenkorb100.96 € (inkl. MwSt)
zzgl. Versandkosten

V O R N E

EBC102698 Yellowstuff Bremsbeläge (Satz für die kompl. Achse)
deutsche Ausführung
Beläge vorne

Weitere Artikelinfos anzeigen x in den Warenkorb130.63 € (inkl. MwSt)
zzgl. Versandkosten

H I N T E N

EBC102691 Yellowstuff Bremsbeläge (Satz für die kompl. Achse)
deutsche Ausführung
Beläge hinten

Weitere Artikelinfos anzeigen x in den Warenkorb105.08 € (inkl. MwSt)
zzgl. Versandkosten

V O R N E

EBC103276 Bluestuff Rennbremsbeläge (Satz für die kompl. Achse)
deutsche Ausführung
Beläge vorne

Weitere Artikelinfos anzeigen x in den Warenkorb130.34 € (inkl. MwSt)
zzgl. Versandkosten

H I N T E N

EBC117044 Bluestuff NDX-Rennbremsbeläge (Satz für die kompl. Achse)
deutsche Ausführung
Beläge hinten

Weitere Artikelinfos anzeigen x in den Warenkorb104.84 € (inkl. MwSt)
zzgl. Versandkosten


EBC107597 Ultra High Performance Sport-Bremsflüssigkeit BF307+ (500ml)
Weitere Artikelinfos anzeigen x in den Warenkorb17.25 € (1 Liter = 34.50 €) (inkl. MwSt)
zzgl. Versandkosten


EBC107596 Bremsflüssigkeit DOT4 (250ml)


Weitere Artikelinfos anzeigen x in den Warenkorb5.35 € (1 Liter = 21.40 €) (inkl. MwSt)
zzgl. Versandkosten


EBC116354 Bremsflüssigkeits-Tester
Weitere Artikelinfos anzeigen x in den Warenkorb46.04 € (inkl. MwSt)
zzgl. Versandkosten


EBC116356 Montagepaste (1 Beutel a 6g Brutto)
Weitere Artikelinfos anzeigen x in den Warenkorb2.67 € (inkl. MwSt)
zzgl. Versandkosten


EBC116359 Bremsenreiniger (1 Dose=400ml)
Weitere Artikelinfos anzeigen x in den Warenkorb8.85 € (1 Liter = 22.13 €) (inkl. MwSt)
zzgl. Versandkosten




Kein passendes EBC Produkt gefunden? Nutzen Sie unser Kontaktformular. WIR HELFEN GERN! "
____________________________

snb
03-25-2013, 06:40 AM
Bitte post a sample workbook !

colonna
03-25-2013, 10:38 AM
this is a sample. Please help :(

colonna
03-29-2013, 07:17 AM
noone ? BUMP

mdmackillop
03-29-2013, 09:20 AM
Can you also show your expected result? I think the Split function is what you need to use.

colonna
03-29-2013, 09:47 AM
i atached the expected result , But right now im using find and mid to try to get that result . Guess what :(( it`s not working

colonna
03-30-2013, 12:21 PM
Up. Noone ? Pls help

colonna
03-31-2013, 04:49 AM
UP.!

sassora
03-31-2013, 05:40 AM
There may be a more elegant way of doing this, but this seems to tidy up the web text:


Sub CleanWebText()
Sub CleanWebText()
Dim txt As String
Dim cnt As Long
Dim txtArr() As String

txt = WorksheetFunction.Clean(Range("A1"))
txt = Mid(txt, Application.WorksheetFunction.Find("Gefundene Artikel", txt))
txt = Left(txt, Application.WorksheetFunction.Find("Kein passendes EBC", txt) - 1)
txt = Replace(txt, " EBC", "xxxx xxxxEBC")
txt = Replace(txt, " V O R N E", "xxxxVORNE")
txt = Replace(txt, "VORNExxxx xxxxEBC", "VORNExxxxEBC")
txt = Replace(txt, " H I N T E N", "xxxxHINTEN")
txt = Replace(txt, "HINTENxxxx xxxxEBC", "HINTENxxxxEBC")
txt = Replace(txt, "Versandkosten ", "Versandkosten")

txtArr = Split(txt, "xxxx")

For cnt = 1 To UBound(txtArr) / 2
Range("B" & cnt) = txtArr(2 * cnt - 1)
Range("C" & cnt) = txtArr(2 * cnt)
Next cnt

End Sub

colonna
03-31-2013, 06:42 AM
wow. it looks so simple when you put it like this .
Please take a look at what i did so far ( the xlsm) atached ).

the expected result should look like in the sheet3. ONCE AGAIN BIG TY

colonna
03-31-2013, 06:52 AM
can you olso explain ur code ... please ... it look strange to me . i just dont get it. PS ... im noob VBA .
But ti does what i need . except extracting Make model , and motor

sassora
03-31-2013, 09:12 AM
1) txt = cleaned up version of web text - remove non-printable characters
2) txt = start text from "Gefundene Artikel" and finish before "Kein passendes EBC..."
3) Replace text with "xxxx" in places to separate parts of string
4) use the split function to create an array, txtArr. Each part has it's own index number.
E.g. if you split a,b,c,d by "," then txtArr(0) = a txtArr(1) = b etc.

The For loop presents the in sheet cells.

I know that this query is linked to another where you were pulling information from a website. It seems possible for you to populate with make, model and motor in the spreadsheet at this stage (with the menu entries you are 'clicking' on) and then add this tidyup macro after each iteration - this way there is no need to find it from the text.

Perhaps post a spreadsheet that collects all the information and we can look at how to integrate the tidyup with this.

colonna
04-01-2013, 01:09 AM
this is a sample of the text extracted(1000 rows , but i actually have like 15.000 rows) . I need to solve this as soon asa possible.
In the Sheet1 is all the data in one cell.! TY in advance, im tryn to do this for someone else ... pls help.!

colonna
04-01-2013, 04:46 AM
in each text cell, i already have here the Mark , modell and motor. Exact in
"Gefundene Artikel für AC - 428 Cabrio (65-74) - 7.0 "
AC - Marke
428 Cabrio (65-74) - Modell
7.0 - motor

sassora
04-01-2013, 04:52 AM
The file doesn't open.

I am also interested in the vba code you have to pull the data from the website. We should be able to use this to help us populate your list without any additional searching around.

sassora
04-01-2013, 04:53 AM
The file doesn't open.

I am also interested in the vba code you have to pull the data from the website. We should be able to use this to help us populate your list without any additional searching around.

colonna
04-01-2013, 07:01 AM
ok , this is the file. (one part of the file , the whole file was to large). pls replay to tell me you can open it. The last file atached , i did redownloaded it .. and was working ok for me.! TY again for your help.!

colonna
04-01-2013, 08:53 AM
not really m8, because i used the ID`s for selecting the dropdownlists. and the motor text for selecting link click. So i think it`s better to extract the text from the resulted data.!

colonna
04-01-2013, 09:09 AM
I think the version was the reason you couldnt open that file. I`ve made it in XLS 2003 format. but with less cells ,because of the size.

sassora
04-01-2013, 10:43 AM
I should be able to take a look later today

colonna
04-01-2013, 12:43 PM
Ok , m8 .... Is there enything i can do in return ? Ssis , ssrs , sap crystal reports ?

colonna
04-01-2013, 12:48 PM
I see your loction flags , soon it's a probably , for me to be in uk and scotland . If you like , ill buy you a bier ..... :)) of course it depends on your actual location . Cheers

sassora
04-01-2013, 01:52 PM
I'm running Excel 2010 so there shouldn't be any compatibility issues.
I get Opening:tst_continuare.xlsm (0%)

The VBA code should be enough, I understand the format of the output.

EDIT: It's opening, just taking ages - I can see some data but it still says 0% ... took a few minutes

colonna
04-01-2013, 03:25 PM
Then , as a sample, you can take the last atachement. It has no macro. I use office 2007. This is strange .... Loading 0%..... hmm.

colonna
04-01-2013, 03:28 PM
Ty, again , for helping me with this ...

colonna
04-02-2013, 06:42 AM
hey m8 , take a look at what i did. I combine you text with mine , and this is what came out. now i must do the lopp and olso autofill the empty spaces of Marke Model and motor. And there is another problem. Some of the text extracted , is incomplete .. and there for it can not find "Artikel fur". Those rows must be skiped . Pls replay as soon as possible. I should give this database today .. :(

colonna
04-02-2013, 06:43 AM
Sub format()

Dim text As String
Dim indexMarca As Integer
Dim indexMarcaf As Integer
Dim indexmodel As Integer
Dim indexmodelf As Integer
Dim indexmot As Integer
Dim indexmotf As Integer
Dim fs As String
Dim ff As String
Dim scod As String
Dim incod As Integer
Dim incodf As Integer
Dim inds As Integer
Dim indsf As Integer
Dim inddet As Integer
Dim inddetf As Integer


fs = "V O R N E"
ff = "H I N T E N"
scod = "EBC"


text = Cells(1, 1).Value

indexMarca = Application.WorksheetFunction.Find("Artikel für", text)
indexMarcaf = Application.WorksheetFunction.Find(" - ", text, indexMarca)
Sheets("Sheet2").Range("A1") = Application.WorksheetFunction.Clean(Mid(text, indexMarca + 11, indexMarcaf - indexMarca - 11))

indexmodel = Application.WorksheetFunction.Find(" - ", text, indexMarcaf)
indexmodelf = Application.WorksheetFunction.Find(" - ", text, indexmodel + 3)
Sheets("Sheet2").Range("B1") = Application.WorksheetFunction.Clean(Mid(text, indexmodel + 3, indexmodelf - indexmodel - 3))

indexmot = Application.WorksheetFunction.Find(" - ", text, indexmodelf)
indexmotf = Application.WorksheetFunction.Find(scod, text, indexmot)
Sheets("Sheet2").Range("C1") = Application.WorksheetFunction.Clean(Mid(text, indexmot + 3, indexmotf - indexmot - 18))

Dim cnt As Long
Dim txt As String
Dim txtArr() As String


txt = WorksheetFunction.Clean(Range("A1"))
txt = Mid(txt, Application.WorksheetFunction.Find("Gefundene Artikel", txt))
txt = Left(txt, Application.WorksheetFunction.Find("Kein passendes EBC", txt) - 1)


txt = Replace(txt, " EBC", "xxxx xxxxEBC")
txt = Replace(txt, " V O R N E", "xxxxVORNE")
txt = Replace(txt, "VORNExxxx xxxxEBC", "VORNExxxxEBC")
txt = Replace(txt, " H I N T E N", "xxxxHINTEN")
txt = Replace(txt, "HINTENxxxx xxxxEBC", "HINTENxxxxEBC")
txt = Replace(txt, "Versandkosten ", "Versandkosten")

txtArr = Split(txt, "xxxx")

For cnt = 1 To UBound(txtArr) / 2

Sheets("Sheet2").Range("D" & cnt) = txtArr(2 * cnt - 1)
Sheets("Sheet2").Range("E" & cnt) = txtArr(2 * cnt)

Next cnt





End Sub

colonna
04-02-2013, 11:53 AM
UPP ,, need help fast!

colonna
04-03-2013, 12:39 AM
noone ??

colonna
04-04-2013, 01:42 AM
BUMP

colonna
04-05-2013, 03:18 AM
up ... Noone .?

colonna
04-06-2013, 02:31 AM
pls help , i already have the code for extracting the data , i just need to loop thru it ,. right now does what i need . but gives me some blank rows.

mdmackillop
04-06-2013, 05:09 AM
Sorry, I can't open any of your attachments; never get passed 1%

mdmackillop
04-06-2013, 06:57 AM
A different approach
Option Explicit

Dim Data As String
Dim Sh As Worksheet

Sub DataToCols()
Application.ScreenUpdating = False
Call Test1
Call Test2
Call Test3
Call Test4
Application.ScreenUpdating = True
End Sub


Private Sub Test1()
Dim cel As Range, i As Long, x As Long

Set Sh = Sheets.Add
Data = Sheets("Sheet1").Cells(1, 1)
Sh.Range("A1:E1") = Array("Gefundene Artikel für", "H I N T E N", "V O R N E", "EBC", "Versandkosten")
For Each cel In Sh.Range("A1:E1")
i = 0
Do
x = InStr(i + 1, Data, cel)
If x > 0 Then
Sh.Cells(Rows.Count, cel.Column).End(xlUp)(2) = x
i = x + 1
End If
Loop Until x = 0
Next
End Sub

Private Sub Test2()
Dim r As Range, Mx As Long, i As Long, S As Long
With Sh
Set r = .Cells(1, 1).CurrentRegion
Mx = Application.Count(r)
For i = 1 To Mx
S = Application.Small(r, i)
.Cells(i, 7) = .Cells(1, r.Find(S).Column)
.Cells(i, 8) = S
.Cells(i, 9).FormulaR1C1 = "=R[1]C[-1]-RC[-1]"
Next
.Range("G1:I1").Delete xlUp
End With
End Sub

Private Sub Test3()
Dim r As Range, cel As Range
Dim i As Long
With Sh
Set r = Range(.Cells(1, 7), .Cells(LR(7), 7))

For Each cel In r
cel.Interior.ColorIndex = 7

Select Case cel
Case "Gefundene Artikel für"
i = LR("K") + 1
.Cells(i, "K") = Mid(Data, cel.Offset(, 1) + 21, cel.Offset(, 2) - 21)

Case "H I N T E N", "V O R N E"
i = LR("L") + 1
.Cells(i, "L") = cel

Case "EBC"
If cel.Offset(, 2) < 0 Then Exit Sub
i = LR("M") + 1
.Cells(i, "M") = Mid(Data, cel.Offset(, 1), 9)
.Cells(i, "N") = Mid(Data, cel.Offset(, 1) + 9, cel.Offset(, 2) - 9)
End Select
Next
End With
End Sub

Private Sub Test4()
With Sh
.Columns("K:M").WrapText = False
.Columns("K:M").Columns.AutoFit
.Columns("N:N").ColumnWidth = 75
.Columns("K:N").VerticalAlignment = xlTop
.Columns("A:J").Delete
End With
End Sub

Function LR(col) As Long
LR = Cells(Rows.Count, col).End(xlUp).Row
End Function

colonna
04-06-2013, 09:19 AM
Thank You ... first of all . Your code does the trick as well. I did add some clean to it .. and works. But i need to make the loop . Wich it`s big strugle for me.
With the old versions ... i generally did the same thing ... until loop :(
I need to make it run for several cells .... like 15.000 cells ... and skip the cells that do not contain "Gerfunde Artkel" .... i atach another file

Sheet 1 : contains the data in the Col A , i put there only 7 rows , but i have some rows that do not contain "gefunde artikel" ... and those must be skiped.
and there are 4 macros , one of the is yours ,with the clean function added.

Please replay, and tell me that you can open it ... and of course ,that you can help me. Im already out of time with this project ... and disperate to solve it .


PLEASE HELP ME LOOP IT ... TY again for your effort ..... hope i can return your effort somehow.

PS. I asume no merit for this , only helping someone.!

colonna
04-06-2013, 09:26 AM
Ohh ... and maybe can be easy for you to tweak the module 3 in the file atached early. It does exactly what i need ... but , Adds some empty rows as well (don`t know why ) , and double the data quantity (Olso no idea why). When you`ll run it ... you`ll see in the sheet2 ,what it does.!

mdmackillop
04-06-2013, 10:17 AM
It's hard to see the duplicates in the Excel format. Can you post a cell of data in Word format?

Here's a loop meantime.

Option Explicit

Dim Data As String
Dim Sh As Worksheet

Sub DataToCols()
Dim cel As Range

'Debug @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Dim i As Long
Application.DisplayAlerts = False
For i = Sheets.Count To 5 Step -1
Sheets(i).Delete
Next
Application.DisplayAlerts = True
'Debug @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

Application.ScreenUpdating = False


For Each cel In Sheets("Sheet1").Cells(1, 1).CurrentRegion
Data = cel
Call Test1
Call Test2
Call Test3
Call Test4
Next
Application.ScreenUpdating = True
End Sub


Private Sub Test1()
Dim cel As Range, i As Long, x As Long

Set Sh = Sheets.Add(after:=Sheets(Sheets.Count))
Sh.Range("A1:E1") = Array("Gefundene Artikel für", "H I N T E N", "V O R N E", "EBC", "Versandkosten")
For Each cel In Sh.Range("A1:E1")
i = 0
Do
x = InStr(i + 1, Data, cel)
If x > 0 Then
Sh.Cells(Rows.Count, cel.Column).End(xlUp)(2) = x
i = x + 1
End If
Loop Until x = 0
Next
End Sub

Private Sub Test2()
Dim r As Range, Mx As Long, i As Long, S As Long
With Sh
Set r = .Cells(1, 1).CurrentRegion
Mx = Application.Count(r)
For i = 1 To Mx
S = Application.Small(r, i)
.Cells(i, 7) = .Cells(1, r.Find(S).Column)
.Cells(i, 8) = S
.Cells(i, 9).FormulaR1C1 = "=R[1]C[-1]-RC[-1]"
Next
.Range("G1:I1").Delete xlUp
End With
End Sub

Private Sub Test3()
Dim r As Range, cel As Range
Dim i As Long
With Sh
Set r = Range(.Cells(1, 7), .Cells(LR(7), 7))

For Each cel In r
cel.Interior.ColorIndex = 7

Select Case cel
Case "Gefundene Artikel für"
i = LR("K") + 1
.Cells(i, "K") = Application.WorksheetFunction.Clean(Mid(Data, cel.Offset(, 1) + 21, cel.Offset(, 2) - 21))

Case "H I N T E N", "V O R N E"
i = LR("L") + 1
.Cells(i, "L") = cel

Case "EBC"
If cel.Offset(, 2) < 0 Then Exit Sub
i = LR("M") + 1
.Cells(cel.Row, "J") = Application.WorksheetFunction.Clean(Mid(Data, cel.Offset(, 1), 9)) 'Debug @@@@@@@@@@@@@@@@@@@@@@@@@@@
.Cells(i, "M") = Application.WorksheetFunction.Clean(Mid(Data, cel.Offset(, 1), 9))
.Cells(i, "N") = Application.WorksheetFunction.Clean(Mid(Data, cel.Offset(, 1) + 9, cel.Offset(, 2) - 9))
End Select
Next
End With
End Sub

Private Sub Test4()
With Sh
.Columns("K:M").WrapText = False
.Columns("K:M").Columns.AutoFit
.Columns("N:N").ColumnWidth = 75
.Columns("K:N").VerticalAlignment = xlTop
'.Columns("A:J").Delete 'Debug @@@@@@@@@@@@@@@@@@@@@@@@@
End With
End Sub

Function LR(col) As Long
LR = Cells(Rows.Count, col).End(xlUp).Row
End Function

colonna
04-06-2013, 10:57 AM
this is how it looks in word format , i tested your loop .. and works .. but creates multiple sheets ... all the data should be in one sheet.

and the first column should be filled with marke - model - motor
Ohh.... you do not have to remove duplicate from the cells ... there must be an IF statement ... if in the celll will not find "Gefunde artikel fur" that one should be skiped ..

:) Good thing is that now i undestand your code :)
you are creating index of each word and the work with them .. nice


TY again

mdmackillop
04-06-2013, 11:55 AM
Option Explicit

Dim Data As String
Dim Sh As Worksheet
Dim Shts As Long


Sub DataToCols()
Dim cel As Range

Application.ScreenUpdating = False

Shts = Sheets.Count
For Each cel In Sheets("Sheet1").Cells(1, 1).CurrentRegion
If InStr(1, cel, "Gefundene Artikel für") > 0 Then
Data = cel
Call Test1
Call Test2
Call Test3
Call Test4
End If
Next
Call Test5
Application.ScreenUpdating = True
End Sub


Private Sub Test1()
Dim cel As Range, i As Long, x As Long

Set Sh = Sheets.Add(after:=Sheets(Sheets.Count))
Sh.Range("A1:E1") = Array("Gefundene Artikel für", "H I N T E N", "V O R N E", "EBC", "Versandkosten")
For Each cel In Sh.Range("A1:E1")
i = 0
Do
x = InStr(i + 1, Data, cel)
If x > 0 Then
Sh.Cells(Rows.Count, cel.Column).End(xlUp)(2) = x
i = x + 1
End If
Loop Until x = 0
Next
End Sub

Private Sub Test2()
Dim r As Range, Mx As Long, i As Long, S As Long
With Sh
Set r = .Cells(1, 1).CurrentRegion
Mx = Application.Count(r)
For i = 1 To Mx
S = Application.Small(r, i)
.Cells(i, 7) = .Cells(1, r.Find(S).Column)
.Cells(i, 8) = S
.Cells(i, 9).FormulaR1C1 = "=R[1]C[-1]-RC[-1]"
Next
.Range("G1:I1").Delete xlUp
End With
End Sub

Private Sub Test3()
Dim r As Range, cel As Range
Dim i As Long
With Sh
Set r = Range(.Cells(1, 7), .Cells(LR(7), 7))

For Each cel In r
cel.Interior.ColorIndex = 7

Select Case cel
Case "Gefundene Artikel für"
i = LR("K") + 1
.Cells(i, "K") = Application.WorksheetFunction.Clean(Mid(Data, cel.Offset(, 1) + 21, cel.Offset(, 2) - 21))

Case "H I N T E N", "V O R N E"
i = LR("L") + 1
.Cells(i, "L") = cel

Case "EBC"
If cel.Offset(, 2) < 0 Then Exit Sub
i = LR("M") + 1
.Cells(cel.Row, "J") = Application.WorksheetFunction.Clean(Mid(Data, cel.Offset(, 1), 9)) 'Debug @@@@@@@@@@@@@@@@@@@@@@@@@@@
If .Cells(i - 1, "K") <> "" Then .Cells(i, "K") = .Cells(i - 1, "K")
.Cells(i, "M") = Application.WorksheetFunction.Clean(Mid(Data, cel.Offset(, 1), 9))
.Cells(i, "N") = Application.WorksheetFunction.Clean(Mid(Data, cel.Offset(, 1) + 9, cel.Offset(, 2) - 9))
End Select
Next
End With
End Sub

Private Sub Test4()
With Sh
.Columns("A:J").Delete
End With
End Sub


Private Sub Test5()
Dim i As Long

Set Sh = Worksheets.Add(after:=Sheets(1))

For i = Shts + 2 To Sheets.Count
Sheets(i).Cells(1).CurrentRegion.Copy Sh.Cells(LR(1), 1)(3)
Next

With Sh
.Columns("A:C").WrapText = False
.Columns("A:C").Columns.AutoFit
.Columns("D:D").ColumnWidth = 75
.Columns("A:D").VerticalAlignment = xlTop
End With

Application.DisplayAlerts = False
For i = Sheets.Count To Shts + 2 Step -1
Sheets(i).Delete
Next
Application.DisplayAlerts = True

End Sub

Function LR(col) As Long
LR = Cells(Rows.Count, col).End(xlUp).Row
End Function

colonna
04-06-2013, 12:33 PM
my friend .... this WORKS like a charm....... but it creates some blank rows.
Please tell what can i do in return ?
i haven`t test it on the whole database ... but it looks like it does what i need.
I can`t test right now ... because im home on the tablet .... but i think i will dress up and go back to the office.
BIG THANK YOU.

mdmackillop
04-06-2013, 12:49 PM
Replace this sub
Private Sub Test5()
Dim i As Long

Set Sh = Worksheets.Add(after:=Sheets(1))

For i = Shts + 2 To Sheets.Count
Sheets(i).Cells(2, 1).CurrentRegion.Copy Sh.Cells(LR(1), 1)(2)
Next

With Sh
.Columns("A:C").WrapText = False
.Columns("A:C").Columns.AutoFit
.Columns("D:D").ColumnWidth = 75
.Columns("A:D").VerticalAlignment = xlTop
End With

Application.DisplayAlerts = False
For i = Sheets.Count To Shts + 2 Step -1
Sheets(i).Delete
Next
Application.DisplayAlerts = True

End Sub

colonna
04-06-2013, 01:06 PM
and .... what can i offer you in return ?

mdmackillop
04-06-2013, 01:08 PM
Just get involved and assist others when you can.

Hope it works out on the full file.

colonna
04-06-2013, 01:10 PM
can you tell me what you did in every sub. It's nice to know ..... but not actually a must. THANK YOU AGAIN ....... there must be something .. i can do in return.!

colonna
04-06-2013, 01:11 PM
right now its working .... CPU 100% ... and still works. ill try assisting .!