Excel - break one column into multiple columns

We have several text documents what look something like this:
4ED
Group 1: ITE-1
Group 2: ITE-2
Group 2: ITE-6
Group 2: DFG-1

7DF
Group 1: RDA-1
Group 2: ITE-2

DEF
Group 1: SIMON
Group 2: LPI
Group 2: K88TS
Group 2: HOUSE1

ZDF
Group 1: LPI

Open in new window


The list can be several thousand lines long and the blocks of data are different sizes as shown.

I have been tasked with entering the data into a spreadsheet with each block of data being a new column.

Does anyone know if it is possible to create a macro (or use an existing Excel feature) that will be able to move each block of data to a new column? Perhaps a rule could be created where the macro sees the blank cell between each block then cuts and pastes the data between each blank cell to a new column.

Sorry for rambling.
LVL 4
pAceMakerNZDesktop Support Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

[ fanpages ]IT Services ConsultantCommented:
Hi,

No need to apologise :)

Just for clarity, with the file contents shown above, the expected outcome is as follows:

Column [ A ]
4ED
Group 1: ITE-1
Group 2: ITE-2
Group 2: ITE-6
Group 2: DFG-1
---
Column [ B ]
7DF
Group 1: RDA-1
Group 2: ITE-2
---
Column [ C ]
DEF
Group 1: SIMON
Group 2: LPI
Group 2: K88TS
Group 2: HOUSE1
---
Column [ D ]
ZDF
Group 1: LPI
---

Is that correct?

The list can be several thousand lines long and the blocks of data are different sizes as shown.

Which version of Microsoft Excel are you using?

I am conscious that there may be potential for a text file's contents to not be able to be represented after splitting each block of data if the number of columns exceeds those supported by MS-Excel.

Finally, are you looking to completely automate the retrieval of the contents of every text file to be processed, or to be able to represent the data within a text file being viewed in MS-Excel at any given time?

That is, do you wish to open every text file in a specific folder & produce the transposed output within separate workbooks (or within multiple worksheets within one single workbook), or be able to open a single text file & then request the manipulation of the contents manually?

BFN,

fp.
0
pAceMakerNZDesktop Support Author Commented:
Thank you for the quick reply.

Your are correct with the layout of the columns.
The Excel versions range from 2003 to 2010.

I'm looking for a manual process, as you mentioned we will run out of columns, so I will need to run the process until we hit the limit and then create a new sheet to continue with.
0
[ fanpages ]IT Services ConsultantCommented:
Hi,

Please test your files with the Q_28234050() subroutine in the attached workbook (with the code from the "basQ_28234050" code module transposed below).

If you are not familiar with how to do this, simply open the attached workbook, then use the [ALT]+[F8] key combination & "Q_28234050" in the list shown, then click the [Run] button.

At the start of the process you will be prompted to select a ".txt" file, so I have also attached the "sample_input.txt" file I was using (created from the sample data you posted above) for convenience.

Option Explicit
Public Sub Q_28234050()

' --------------------------------------------------------------------------------------------------------------
' [ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28234050.html ]
'
' Question Channel: Experts Exchange > Software > Office / Productivity > Office Suites > MS Office > MS Excel
'
' ID:               Q_28234050
' Question Title:   Excel - break one column into multiple columns
' Question Asker:   pAceMakerNZ                               [ http://www.experts-exchange.com/M_3578373.html ]
' Question Dated:   2013-09-09 at 02:52:55
'
' Expert Comment:   fanpages                                   [ http://www.experts-exchange.com/M_258171.html ]
' Copyright:        (c) 2013 Clearlogic Concepts (UK) Limited                           [ http://NigelLee.info ]
' --------------------------------------------------------------------------------------------------------------

  Dim blnErr_Ignore                                     As Boolean
  Dim intColumn                                         As Integer
  Dim lngErr_Number                                     As Long
  Dim lngLast_Row                                       As Long
  Dim lngRow                                            As Long
  Dim objCell                                           As Range
  Dim objRange                                          As Range
  Dim objThis_Workbook                                  As Workbook
  Dim objWorkbook                                       As Workbook
  Dim objWorksheet                                      As Worksheet
  Dim strErr_Description                                As String
  Dim strFilename                                       As String

  On Error GoTo Err_Q_28234050
  
  blnErr_Ignore = False
  
  Set objThis_Workbook = ThisWorkbook
  Set objWorkbook = Nothing
  Set objWorksheet = Nothing
  Set objRange = Nothing
  Set objCell = Nothing
  
  strFilename = strLocate_Filename()
  
  If Len(Trim$(strFilename)) = 0 Then
     MsgBox "No file selected!", _
            vbInformation Or vbOKOnly, _
            ThisWorkbook.Name
  Else
     Application.StatusBar = "Processing input file - Please wait..."
     
     Application.ScreenUpdating = False

     Set objWorkbook = Workbooks.Open(Filename:=strFilename, ReadOnly:=True)
     
     Set objWorksheet = objThis_Workbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
     
     Err.Clear
     lngErr_Number = 0&
     
     blnErr_Ignore = True
     objWorksheet.Name = ActiveSheet.Name
     blnErr_Ignore = False
     
     If lngErr_Number <> 0& Then
        objWorksheet.Name = Format$(Now(), "yyyymmdd_hhmmss")
     End If ' If lngErr_Number <> 0& Then
     
     lngLast_Row = Cells(Cells.Rows.Count, 1).End(xlUp).Row + 1&
     
     Set objRange = Range([A1], Cells(lngLast_Row, 1))
           
     lngRow = 1&
     
     Set objCell = objRange.Find(What:="", _
                                 LookAt:=xlWhole, _
                                 SearchDirection:=xlNext)
     
     While Not (objCell Is Nothing)
     
         intColumn = intColumn + 1
        
         If intColumn <= Cells.Columns.Count Then
            Range(Cells(lngRow, 1), Cells(objCell.Row - 1&, 1)).Copy
           
            objThis_Workbook.Activate
            objWorksheet.Select
            objWorksheet.Cells(1&, intColumn).PasteSpecial Paste:=xlPasteValues
           
            objWorkbook.Activate
         End If ' If intColumn <= Cells.Columns.Count Then
     
         lngRow = objCell.Row + 1&
         
         If objCell.Row < lngLast_Row Then
            Set objRange = Range(objCell.Offset(1&), Cells(lngLast_Row, 1))
            
            Set objCell = objRange.Find(What:="", _
                                        LookAt:=xlWhole, _
                                        SearchDirection:=xlNext)
         Else
            Set objCell = Nothing
         End If ' If objCell.Row < lngLast_Row Then
            
     Wend ' While Not (objCell Is Nothing)
  End If ' If Len(Trim$(strFilename)) = 0 Then

Exit_Q_28234050:

  On Error Resume Next
  
  Set objCell = Nothing
  Set objRange = Nothing
  
  If Not (objWorkbook Is Nothing) Then
     objWorkbook.Close SaveChanges:=False
     
     Set objWorkbook = Nothing
  End If ' If Not (objWorkbook Is Nothing) Then
  
  If Not (objThis_Workbook Is Nothing) Then
     objThis_Workbook.Select
     
     Set objThis_Workbook = Nothing
  End If ' If Not (objThis_Workbook Is Nothing) Then
  
  If Not (objWorksheet Is Nothing) Then
     objWorksheet.Select
     
     Cells.EntireColumn.AutoFit
     
     Set objWorksheet = Nothing
  End If ' If Not (objWorksheet Is Nothing) Then
  
  [A1].Select
  
  Application.StatusBar = False
  
  Application.ScreenUpdating = True
  
  Exit Sub
  
Err_Q_28234050:

  lngErr_Number = Err.Number
  strErr_Description = Err.Description
  
  On Error Resume Next
  
  If (blnErr_Ignore) Then
     On Error GoTo Err_Q_28234050
     Resume Next
  End If ' If (blnErr_Ignore) Then
  
  Application.ScreenUpdating = True
  
  MsgBox "Error #" & CStr(lngErr_Number) & _
         vbCrLf & vbLf & _
         strErr_Description, _
         vbExclamation Or vbOKOnly, _
         ThisWorkbook.Name
         
  Resume Exit_Q_28234050

End Sub
Private Function strLocate_Filename() As String

  Dim strReturn                                         As String
  Dim vntFilename                                       As Variant
  
  On Error Resume Next
  
  strReturn = ""
  
  vntFilename = Application.GetOpenFilename(Title:="Select a file to import", _
                                            fileFilter:="ASCII Text Files (*.txt),*.txt,All Files (*.*),*.*", _
                                            FilterIndex:=1&, _
                                            MultiSelect:=False)
  
  If VarType(vntFilename) <> vbBoolean Then
     strReturn = CStr(vntFilename)
  End If ' If VarType(vntFilename) <> vbBoolean Then
  
  strLocate_Filename = strReturn
  
End Function

Open in new window


Thanks for your feedback.

BFN,

fp.
sample-input.txt
Q-28234050.xls
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
pAceMakerNZDesktop Support Author Commented:
Perfect!

Thank you so much for your time and effort. Saved us so much time!
0
[ fanpages ]IT Services ConsultantCommented:
You're very welcome.

Good luck with the rest of your project.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.