Converting multiple columns to one & use in a defined ra

[aka_krakur]

I have a query that brings back data that is separated by a semicolon. I then break those apart into separate columns because each data after each semicolon is it's own code and I am using these in a listbox on a userform.

Manually this is no problem; but I need to validate where these codes are coming from, so I created a query that looks them up and refreshes the list accordingly. Again, this is all manually done right now.

so, the steps I do I've started recording a macro but where I come into trouble is sometimes Column A when I convert to separate columns so I can get one long list, it varies how many columns it's expanded in to. Sometimes it could be up to Column H, sometimes it's only to Column F.

Maybe I'm going about this all wrong and there's an easier way to accomplish getting all these codes into one column so it may be used on a userform in a listbox.

Criteria that's a must.
1. I have to split them up (semicolon is the factor that helps with this)
2. I have to remove duplicates.
3. Defined Name Range will probably change every once in a while.

Here is a pasted sample of the data I am working with:

BEFORE

Book1
	A	B	C	D
1	Before
2	REPORTED_DEV_CLARIFICATION
3	1049-Above;
4	1049-Above;1069-Shaft;1670-AboveRBP;
5	1049-Above;1586-Balloon;
6	1049-Above;1586-Balloon;1670-AboveRBP;
7	1049-Above;1586-Balloon;1670-AboveRBP;1586-Tip;
8	1049-Above;1586-Shaft;1670-AboveRBP;1670-AgainstResistance;
9	1049-Above;1670-AboveRBP;
10	1049-Above;1670-AboveRBP;1528-BalloonCatheter;1586-Balloon;
11	1049-Above;1670-AboveRBP;1586-Balloon;
12	1049-Above;1670-AboveRBP;1586-Shaft;1586-Balloon;
13	1049-Below;
14	1049-Below;1158-Dislodged;
15	1049-Below;1158-Partial;1670-OffLabelUse;
16	1049-Below;1528-GuideWire;
17	1049-Below;1528-GuideWire;1670-OffLabelUse;
18	1049-Below;1586-Balloon;
19	1049-Below;1586-Shaft;
20	1049-Below;1586-Shaft;1670-OffLabelUse;
Sheet1

AFTER

Book1
	A	B	C	D
22	After
23	REPORTED_DEV_CLARIFICATION
24	1049-Above
25	1049-Above	1069-Shaft	1670-AboveRBP
26	1049-Above	1586-Balloon
27	1049-Above	1586-Balloon	1670-AboveRBP
28	1049-Above	1586-Balloon	1670-AboveRBP	1586-Tip
29	1049-Above	1586-Shaft	1670-AboveRBP	1670-AgainstResistance
30	1049-Above	1670-AboveRBP
31	1049-Above	1670-AboveRBP	1528-BalloonCatheter	1586-Balloon
32	1049-Above	1670-AboveRBP	1586-Balloon
33	1049-Above	1670-AboveRBP	1586-Shaft	1586-Balloon
34	1049-Below
35	1049-Below	1158-Dislodged
36	1049-Below	1158-Partial	1670-OffLabelUse
37	1049-Below	1528-GuideWire
38	1049-Below	1528-GuideWire	1670-OffLabelUse
39	1049-Below	1586-Balloon
40	1049-Below	1586-Shaft
41	1049-Below	1586-Shaft	1670-OffLabelUse
Sheet1

 

[gingerafro]

so is the next step after this to put columns b,c, and d underneath column A and then filter to get unique data?

 

[aka_krakur]

Yes. But that's where I get stuck. Because this is just a sample data. Sometime it could be up to Column F. It varies on this aspect.

 

[aka_krakur]

Well, I don't see any responses in a couple days.
Any chance anyone can help me with this.
Looking to see if there's a code that can automatically combine split columns into one continous list. (See 1st posting for samples and more detail as to what I'm looking to accomplish.

 

[gingerafro]

sorry, got sidetracked
try this (its untested)

Sub selectcells()
Dim c As Range
x = 1
y = 2

Worksheets("Sheet1").Activate
Do
For Each c In Range(Cells(x, y), Cells(10, y))
If c <> "" Then c.Select
Selection.Cut
Columns("A:A").Select
Selection.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Select
lastcell = Selection.Row
Cells(lastcell, 1).Activate
ActiveSheet.Paste
Next
y = y + 1
Loop Until y = 8

End Sub

 

[aka_krakur]

That does it....thanks.

David

 

[aka_krakur]

The code that gingerafro helped me with works, but it's a huge loop that takes forever when it comes to using it with all my data (about 2550 rows worth).

Dim c As Range
x = 1
Y = 2

Worksheets("Reported_Dev_Clarification").Activate
lastCell = Range("A65536").End(xlUp).Row
Do
For Each c In Range(Cells(x, Y), Cells(lastCell, Y))
If c <> "" Then c.Select
Selection.Cut
Columns("A:A").Select
Selection.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Select
lastCell = Selection.Row
Cells(lastCell, 1).Activate
ActiveSheet.Paste
Next
Y = Y + 1
Loop Until Y = 8

Here's the code I originally started with (and it works as it was based off of a simple recorded macro); however, the problem I run in to is --
Is there a way to write an if statement or something of that nature to stop the sorting, etc, if it recognizes that column to have no data?

Here's my code:

Sub MacroOLD()

'Sort Columns - Descending (This gets rid of blank rows)

      Range("B2:B65536").Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("C2:C65536").Select
    Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("D2:D65536").Select
    Selection.Sort Key1:=Range("D2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("E2:E65536").Select
    Selection.Sort Key1:=Range("E2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("F2:F65536").Select
    Selection.Sort Key1:=Range("F2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("G2:G65536").Select
    Selection.Sort Key1:=Range("G2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("H2:H65536").Select
    Selection.Sort Key1:=Range("H2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
   Range("I2:I65536").Select
    Selection.Sort Key1:=Range("I2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("J2:J65536").Select
    Selection.Sort Key1:=Range("J2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
  Range("K2:K65536").Select
    Selection.Sort Key1:=Range("K2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Range("L2:L65536").Select
    Selection.Sort Key1:=Range("L2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Range("M2:M65536").Select
    Selection.Sort Key1:=Range("M2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    ' Copymove Macro--copies each column according to the last set of data in that row over to end of data on column A
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Range("A2").Select
    Selection.End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    Range("C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Range("A2").Select
    Selection.End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    Range("D2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Range("A2").Select
    Selection.End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    Range("E2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Range("A2").Select
    Selection.End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    Range("F2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Range("A2").Select
    Selection.End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    Range("G2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Range("A2").Select
    Selection.End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste

Problem is if let's say Column G2 didn't have any data in it, the macro stops at this point because it can't copy/paste G2:G65536 (which is what it selects) at this point if there's no data) into Column A(lastrow)

If someone can show me how to write an if statement (if that's possible) to make it stop the code if there's no data, or keep going (loop) until it finds blank data---I would appreciate it.

The 1st code above was nice; it just is a huge time consuming loop. Mine doesn't take but a few sec's; but I need to sureproof it to stop when there's no data, or keep going if there is.