Macro to copy values from columns and insert into column list

[Jeffrey_1]

I copied a list into Excel and some of the list formatted into the neihgboring columns instead of lining up in the list. I need to get the items floating out in the columns back into the proper place in the list. I assume I need to somehow run a Macro to insert a row below each cell in columns B-ZZ that contain text, and then somehow copy/past the floating values to Column A in the appropriate new row. Is there a Macro that can help? See below for example of issue.

A          B        C        D    ....  ZZ
item 1
item 2    item3     item4    item5 ...  item 255
item 256
Item 257  item 258
Item 259
Item 260
....

[Stuugie]

Hi Jeffrey 1, this is definitely doable but may take a moment to come up with the right macros to make. In saying that, there will be a significant amount of looping required (at first glance) and because of this, depending on the file size, the process may take a while. I'm working on this for you though so hang in there.

[Stuugie]

Alright, try the following on a data sample and let me know how it goes.

Sub OrganizeItemColumn()
    '*****************************************************************'
    '**This procedure goes through a user-defined column          **'
    '**Most likely A and puts all item numbers correctly down the   **'
    '**column.                                                      **'
    '**Created by Stuugie @ www.daniweb.com                         **'
    '**Date: Jan 31, 2014                                           **'
    '*****************************************************************'
    '**                                                             **'

    Dim cNum As Long, iNum As Long, jNum As Long
    Dim aWs As Worksheet, cRng As Range, oC As Range
    Dim inAns As String, iRng As Range, jRng As Range

    Set aWs = ActiveSheet
    inAns = InputBox("Please Enter the Column Number where A=1, B=2, and so on", "Column Number")
    If IsLetter(inAns) = True Then
        MsgBox "You have not entered a valid number, please run the program again." & vbNewLine _
        & "You have entered: " & inAns
        Exit Sub
    Else
        cNum = CLng(inAns)
    End If
    '*****************************************************************'
    '**Set the range used in the column selected by the user from   **'
    '**above input,starting at row 1 (change as necessary).         **'
    '*****************************************************************'
    '**                                                             **'
    Set cRng = aWs.Range(aWs.Cells(1, cNum), aWs.Cells(aWs.Rows.Count, cNum).End(xlUp))
    '*****************************************************************'
    '**Loop through each cell in the cRng and check to ensure for   **'
    '**data to right of column cell.                                **'
    '*****************************************************************'
    '**                                                             **'
    For Each oC In cRng
        If oC.Offset(0, 1).Value <> "" Then
            Set iRng = aWs.Range(aWs.Cells(oC.Row, oC.Offset(0, 1).Column), aWs.Cells(oC.Row, aWs.Columns.Count).End(xlToLeft))
            iNum = iRng.Cells.Count
            aWs.Rows(oC.Offset(1, 0).Row & ":" & oC.Row + iNum).EntireRow.Insert xlDown
            Set jRng = aWs.Range(aWs.Cells(oC.Offset(1, 0).Row, oC.Column), aWs.Cells(oC.End(xlDown).Offset(-1, 0).Row, oC.Column))
            jNum = jRng.Cells.Count
            iRng.Copy
            jRng.PasteSpecial Paste:=xlPasteAll, Transpose:=True
            iRng.Clear
        End If
        Set iRng = Nothing
        Set jRng = Nothing
        iNum = 0
        jNum = 0
    Next oC
End Sub

Function IsLetter(strValue As String) As Boolean
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    '''The IsLetter function checks the variable:   '''
    '''strValue to see if it is a number or a letter'''
    '''If it is a letter, return Boolean True.      '''
    '''If it is a number, return Boolean False.     '''
    '''Author: Stuugie @ www.daniweb.com            '''
    '''Date: Jan 31 2014.                       '''
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim intPos As Integer

    For intPos = 1 To Len(strValue)
        Select Case Asc(Mid(strValue, intPos, 1))
            Case 65 To 90, 97 To 122
                IsLetter = True
            Case Else
                IsLetter = False
                Exit For
        End Select
    Next intPos
End Function

[Jeffrey_1]

Impressive, worked like a charm! Thanks for your help!

[Stuugie]

You're very welcome. If it worked like a charm and your issue has been resolved, please mark this thread as solved and have a great day.

[Stuugie]

Nevermind, it's marked solved, thanks.