I need to propagate cell values to a row, it's sort of difficult to explain...
I have a cell which is always going to be populated with binary values, for example "01110011"
the number changes according to other formulas.
what I need to do is take similar adjacent values and populate a raw with them...
a picture is worth a thousand words I suppose...
http://s28.postimg.org/mf42j9ftp/223.jpg
So basically I need to take the A1 cell and split it across a row...
and I have no idea what so ever how it's done.
I think you will find the LEFT, RIGHT, and MID functions useful. If you were to put all the values that you need to split, like 01110011 (the binary string you used as an example), in column A, you could split it in columns B, C, D and E with the following formulas:
Column B:
=LEFT($A1,1)
Column C:
=MID($A1,2,3)
Column D:
=MID($A1,5,2)
Column E:
=RIGHT($A1,2)
The LEFT function takes a cell as the first argument and the number of characters you want from that cell starting with the leftmost character. The RIGHT function does the same but from the rightmost character. The MID function takes the cell as the first argument, the index of the character you wish to begin from as the second argument, and the number of characters you wish to return as the third argument.
This should help you
Sub splitCell()
Dim cellContent As String
Dim partOfCell As String
Dim columnCounter As Integer
'just to be sure set row format as text to support 00
Rows(2).ClearContents
Rows(2).NumberFormat = "#"
cellContent = CStr(Cells(1, 1))
columnCounter = 1
If Len(cellContent) > 0 Then
partOfCell = Mid(cellContent, 1, 1)
End If
For i = 2 To Len(cellContent)
If Mid(cellContent, i, 1) = Mid(partOfCell, 1, 1) Then
partOfCell = partOfCell + Mid(cellContent, i, 1)
Else
Cells(2, columnCounter) = partOfCell
partOfCell = Mid(cellContent, i, 1)
columnCounter = columnCounter + 1
End If
Next i
Cells(2, columnCounter) = partOfCell
End Sub
Try this option as well,
Sub ListStringIntoB()
'Loop through string, list characters into Starting B1 and over
Dim str As String, Cnt As Integer, A1 As Range, Lp As Integer
Dim col As Long, Rng As Range, r As Range
Set A1 = Range("A1")
str = A1
Cnt = Len(A1)
For Lp = 1 To Cnt
col = Cells(1, Columns.Count).End(xlToLeft).Column + 1
Set Rng = Cells(1, col)
Rng = Mid(str, Lp, 1)
Next Lp
End Sub
Thank you guys for trying to help, I finally found the answer to my predicament... I had to use this code to do the trick..
Sub SplitBinaryNumbers()
Dim Bin As Variant
Bin = Application.Transpose(Split(Replace(Replace(Range("A8").Value, "01", "0,1"), "10", "1,0"), ","))
With Range("A20").Resize(UBound(Bin))
.NumberFormat = "#"
.Cells = Bin
End With
End Sub
I hope this helps someone.
Related
Assume to have the following Excel table
I'm trying to write a Macro in VBA which scans the cells in the routing column and spreads the substrings into the other columns. So this should be the final result
Potentially if the algorithm finds n substrings in the main string under the column Rtg it should fill n columns with the substrings.
Can you guys help me?
Thanks in advance
We can parse using the dash character:
Sub dural()
Dim i As Long, N As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To N
arr = Split(Cells(i, 2).Value, "-")
Cells(i, 2).Offset(0, 1).Resize(1, UBound(arr) + 1) = arr
Next i
End Sub
EDIT#1:
The code will err if it encounters an empty cell prematurely. To avoid this use:
Sub dural()
Dim i As Long, N As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To N
v = Cells(i, 2).Value
If v <> "" Then
arr = Split(v, "-")
Cells(i, 3).Resize(1, UBound(arr) + 1) = arr
End If
Next i
End Sub
As outlined here, you can use Text to Columns:
Select the cell or column that contains the text you want to split.
Select Data > Text to Columns.
In the Convert Text to Columns Wizard, select Delimited > Next.
Select the Delimiters for your data. You'd want to put a - in the "Other" area.
Select Next.
Select the Column data format or use what Excel chose for you.
Select the Destination, which is where you want the split data to
appear on your worksheet.
Select Finish.
Here is a simple sub for operating on the current active cell.
Sub splitCell()
Dim cellSplit As Variant
Dim nextColumn As Long
nextColumn = 1
cellSplit = Split(ActiveCell.Value2, "-")
For Each Item In cellSplit
ActiveCell.Offset(0, nextColumn).Value2 = Item
nextColumn = nextColumn + 1
Next
End Sub
None of the other solutions appear to deal with leading hyphens correctly.
This should deal with leading/trailing/double hyphens on the currently selected cells within one column. The caveat is that the individual substrings should not contain spaces.
Sub splitHyphens()
Dim i As Long, sel As Range, vals As Variant
For Each sel In Selection
vals = Split(Application.Trim(Replace(sel.Value, "-", Space(1))), Space(1))
sel.Offset(0, 1).Resize(1, UBound(vals) + 1) = vals
Next sel
End Sub
I need to find a way to split some data on excel: e.g.
If a cell has the following in: LWPO0001653/1654/1742/1876/241
All of the info after the / should be LWPO000... with that number.
Is there anyway of separating them out and adding in the LWPO000in? So they come out as LWPO0001653
LWPO0001654
etc etc
I could do manually yes, but i have thousands to do so would take a long time.
Appreciate your help!
Here is a solution using Excel Formulas.
With your original string in A1, and assuming the first seven characters are the one's that get repeated, then:
B1: =LEFT($A1,FIND("/",$A1)-1)
C1: =IF(LEN($A1)-LEN(SUBSTITUTE($A1,"/",""))< COLUMNS($A:A),"",LEFT($A1,7)&TRIM(MID(SUBSTITUTE(MID($A1,8,99),"/",REPT(" ",99)),(COLUMNS($A:A))*99,99)))
Select C1 and fill right as far as required. Then Fill down from Row 1
EDIT: For a VBA solution, try this code. It assumes the source data is in column A, and puts the results adjacent starting in Column B (easily changed if necessary). It works using arrays within VBA, as doing multiple worksheet read/writes can slow things down. It will handle different numbers of splits in the various cells, although could be shortened if we knew the number of splits was always the same.
Option Explicit
Sub SplitSlash()
Dim vSrc As Variant
Dim rRes As Range, vRes() As Variant
Dim sFirst7 As String
Dim V As Variant
Dim COL As Collection
Dim I As Long, J As Long
Dim lMaxColCount As Long
Set rRes = Range("B1") 'Set to A1 to overwrite
vSrc = Range("a1", Cells(Rows.Count, "A").End(xlUp))
'If only a single cell, vSrc won't be an array, so change it
If Not IsArray(vSrc) Then
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = Range("a1")
End If
'use collection since number of columns can vary
Set COL = New Collection
For I = 1 To UBound(vSrc)
sFirst7 = Left(vSrc(I, 1), 7)
V = Split(vSrc(I, 1), "/")
For J = 1 To UBound(V)
V(J) = sFirst7 & V(J)
Next J
lMaxColCount = IIf(lMaxColCount < UBound(V), UBound(V), lMaxColCount)
COL.Add V
Next I
'Results array
ReDim vRes(1 To COL.Count, 1 To lMaxColCount + 1)
For I = 1 To UBound(vRes, 1)
For J = 0 To UBound(COL(I))
vRes(I, J + 1) = COL(I)(J)
Next J
Next I
'Write results to sheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
I'm clearly missing the point :-) but anyway, in B1 and copied down to suit:
=SUBSTITUTE(A1,"/","/"&LEFT(A1,7))
Select ColumnB, Copy and Paste Special, Values over the top.
Apply Text to Columns to ColumnB, Delimited, with / as the delimiter.
There's a couple of ways to solve this. The quickest is probably:
Assuming that the data is in column A:
Highlight the column, go to Data>>Text To Columns
Choose "Delimited" and in the "Other" box, put /
Click ok. You'll have your data split into multiple cells
Insert a column at B and put in the formula =Left(A1, 7)
Insert a column at C and pit in formula =Right(A1, Length(A1)-7)
You'll now have Column B with your first 7 characters, and columns B,C,D,E,F, etc.. with the last little bit. You can concatenate the values back together for each column you have with =Concatenate(B1,C1), =Concatenate(B1,D1), etc..
A quick VBa, which does nearly the same thing that #Kevin's does as well. I wrote it before I saw his answer, and I hate to throw away work ;)
Sub breakUpCell()
Dim rngInput As Range, rngInputCell As Range
Dim intColumn As Integer
Dim arrInput() As String
Dim strStart As String
Dim strEnd As Variant
'Set the range for the list of values (Assuming Sheet1 and A1 is the start)
Set rngInput = Sheet1.Range("A1").Resize(Sheet1.Range("A1").End(xlDown).Row)
'Loop through each cell in the range
For Each rngInputCell In rngInput
'Split up the values after the first 7 characters using "/" as the delimiter
arrInput = Split(Right(rngInputCell.Value, Len(rngInputCell.Value) - 7), "/")
'grab the first 7 characters
strStart = Left(rngInputCell.Value, 7)
'We'll be writing out the values starting in column 2 (B)
intColumn = 2
'Loop through each split up value and assign to strEnd
For Each strEnd In arrInput
'Write the concatenated value out starting at column B in the same row as rngInputCell
Sheet1.Cells(rngInputCell.Row, intColumn).Value = strStart & strEnd
'Head to the next column (C, then D, then E, etc)
intColumn = intColumn + 1
Next strEnd
Next rngInputCell
End Sub
Here is how you can do it with a macro:
This is what is happening:
1) Set range to process
2) Loop through each cell in range and check it isn't blank
3) If the cell contains the slash character then split it and process
4) Skip the first record and concatenate "LWPO000" plus the current string to adjacent cells.
Sub CreateLWPO()
On Error Resume Next
Application.ScreenUpdating = False
Dim theRange
Dim cellValue
Dim offset As Integer
Dim fields
'set the range of cells to be processed here
Set theRange = range("A1:A50")
'loop through each cell and if not blank process
For Each c In theRange
offset = 0 'this will be used to offset each item found 1 cell to the right (change this number to this first column to be populated)
If c.Value <> "" Then
cellValue = c.Value
If InStr(cellValue, "/") > 0 Then
fields = Split(cellValue, "/")
For i = 1 To UBound(fields)
offset = offset + 1
cellValue = "LWPO000" & fields(i)
'if you need to pad the number of zeros based on length do this and comment the line above
'cellValue = "LWPO" & Right$(String(7, "0") & fields(i), 7)
c.offset(0, offset).Value = cellValue
Next i
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Basically what I'm trying to do is the following:
First, determine if I'm in the correct row of cells based on the String value of the cell.
i.e If the current cell's string value contains the string AB1 or AB2, go through the entire row.
Once that has been determined, I would like to highlight the cells either green (if the cell holds a value greater than 5) or blue (if the cell holds a value between 4 and 5).
The above if block is not giving me trouble, it's the initial procedure.
What is stopping me from completing this is the run-time [error '91']: "Object variable or With block variable not set".
I have some programming experience, but no VBA experience. Any help would be greatly appreciated.
Sub ChangeCellColor()
Dim columnD As Range
Dim str1, str2 As String
Dim currCell As Range
Dim rightCell As Range
Dim i As Long
str1 = "AB1"
str2 = "AB2"
Columns(1).Font.Color = vbBlack
For i = 1 To Rows.Count
'If the current cell in the D column contains either the string AB1 or AB2, it will look into the values here.
If (currCell.Cells(i, 4).Value = str1) Or (currCell.Cells(i, 4).Value = str2) Then
'From the cell range of
For j = 1 To Range("E10").End(xlToRight)
If rightCell.Cells(j, 5) >= 5# Then
rightCell.Interior.Color = vbRed
ElseIf (rightCell.Cells(j, 5) >= 4 And rightCell.Cells(j, 5) <= 4.99) Then
cell.Interior.Color = vbYellow
End If
Next j
End If
Next i
End Sub
Try this: the following code looks at each cell in Column D, and checks the cell value to determine if cell.value = str1 or str2. Then, it loops through each cell in that row, beginning with column E, changing the color based on your parameters.
Also, try the Usedrange property of the Worksheet object to get the number of rows you need.
Sub ChangeCellColor()
Dim str1, str2 As String
Dim i As Integer
Dim j As Integer
Dim col As Integer
str1 = "AB1"
str2 = "AB2"
Columns(1).Font.Color = vbBlack
For i = 1 To ThisWorksheet.Usedrange.Rows.Count
With ThisWorksheet
'If the current cell in the D column contains either the string AB1 or AB2, it will look into the values here.
If .Cells(i, 4).Value = str1 Or .Cells(i, 4).Value = str2 Then
col = .Range("D" & i).End(xltoRight).Column
For j = 5 To col
If .Cells(i, j).Value >= 5 Then
.Cells(i,j).Interior.Color = vbRed
Else
If .Cells(i, j).Value >= 4 And .Cells(i, j).Value <= 4.99 Then
.Cells(i,j).Interior.Color = vbYellow
End If
End If
Next j
End If
End With
Next i
End Sub
There are a several issues...First, the error is because assigning to a Range variable requires the Set keyword, like so:
Set columnD = Range("D:D")
Second, in your For loop, you're comparing an integer to a range. If you want to loop through to the right-most column, you can do this:
For j = 1 to Range("E10").End(xlToRight).Column
Third, it looks like you've intended to use i for rows and j for columns? If so, you've got your js in the wrong place.
Assuming that is are rows and js are columns, I believe that as you're checking your cells for values, you should be referencing Cells(i, j,), (making both column and row selection dynamic) rather than hardcoding the value of 5.
Finally, you actually don't need those three range variables that you declared at the beginning at all. There's no need to position the cell inside an existing range (though you can if you wish). VBA assumes that you're dealing with the active sheet of the active workbook. As long as those two assumptions hold, then Cells(i,j) works just fine. If you want to add some specificity/protect from running on the wrong sheet, you can use Sheets("Sheet1").Cells(i,j).
PS--I assume that the '#' after the 5 is a typo?
You might want to either assign range value to currCell and rightCell or get rid of it.
Sub ChangeCellColor()
Dim columnD As Range
Dim str1, str2 As String
Dim currCell As Range
Dim rightCell As Range
Dim i As Long
str1 = "AB1"
str2 = "AB2"
Columns(1).Font.Color = vbBlack
For i = 1 To Rows.Count
'If the current cell in the D column contains either the string AB1 or AB2, it will look into the values here.
If (Cells(i, 4).Value = str1) Or (Cells(i, 4).Value = str2) Then
'From the cell range of
For j = 1 To Range("E10").End(xlToRight)
If Cells(j, 5) >= 5 Then
Cells(j, 5).Interior.Color = vbRed
ElseIf (Cells(j, 5) >= 4 And Cells(j, 5) <= 4.99) Then
Cells(j, 5).Interior.Color = vbYellow
End If
Next j
End If
Next i
End Sub
I think possible without VBA but with Conditional Formatting and, for green, a formula rule such as:
=AND(OR(NOT(ISERROR(FIND("AB1",$D1))),NOT(ISERROR(FIND("AB2",$D1)))),N(A1)>5)
I have a number of ranges to concatenate independently and put the values of the concatenated ranges into different cells.
I want to:
concatenate values in Range A1:A10 and put the result in F1
then concatenate the Range B1:B10 and put the result in F2
then concatenate the Range C1:C10 and put the result in F3 etc.
The following macro concatenates range A1:A10 and then puts the results into F1 (which is what I want). However it also stores the information from the first concatenation into memory so that when it does the next concatenation, in cell F2 I get the concatenated results of F1 and F2 joined.
Sub concatenate()
Dim x As String
Dim Y As String
For m = 2 To 5
Y = Worksheets("Variables").Cells(m, 5).Value
'Above essentially has the range information e.g. a1:a10 in sheet variables
For Each Cell In Range("" & Y & "") 'i.e. range A1:A10
If Cell.Value = "" Then GoTo Line1 'this tells the macro to continue until a blank cell is reached
x = x & Cell.Value & "," 'this provides the concatenated cell value
Next
Line1:
ActiveCell.Value = x
ActiveCell.Offset(1, 0).Select
Next m
End Sub
Here is my ConcatenateRange. It allows you to add a seperator if you please. It is optimized to handle large ranges since it works by dumping the data in a variant array and working with it within VBA.
You would use it like this:
=ConcatenateRange(A1:A10)
The code:
Function ConcatenateRange(ByVal cell_range As range, _
Optional ByVal seperator As String) As String
Dim newString As String
Dim cellArray As Variant
Dim i As Long, j As Long
cellArray = cell_range.Value
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
newString = newString & (seperator & cellArray(i, j))
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function
... I would do this very differently... Why not create a function along the lines of:
Function ConcatMe(Rng As Range) As String
Dim cl As Range
ConcatMe = ""
For Each cl In Rng
ConcatMe = ConcatMe & cl.Text
Next cl
End Function
And then just, for example, set F1 = ConcatMe(A1:A10) or, then write code to assign the function to the cells you want...
Or, as #KazJaw mentioned in his comment, just set x="" before re-looping.
Hope this helps
it is similar to the idea posted here already. However, I use a for each loop instead of an array setup with nested for loops.
Function ConcRange(ByRef myRange As Range, Optional ByVal Seperator As String = "")
ConcRange = vbNullString
Dim rngCell As Range
For Each rngCell In myRange
If ConcRange = vbNullString Then
If Not rngCell.Value = vbNullString Then
ConcRange = CStr(rngCell.Value)
End If
Else
If Not rngCell.Value = vbNullString Then
ConcRange = ConcRange & Seperator & CStr(rngCell.Value)
End If
End If
Next rngCell
End Function
This, I suppose would be faster than the array set up, as a new array is not created each time this function runs.
Right before Next m insert simple statement: x="" – KazimierzJawor Apr 8 '13 at 20:43
took me several minutes to notice this answer was under comments :p
Thanks for everything guys, for my purpose I have modified your suggestions and amended my code as it didn't quite fit into a neat function as I needed it to be more dynamic. See my code below. It does exactly what I need.
Sub concatenate()
Dim x As String
Dim Y As String
For Q = 1 To 10 'This provides a column reference to concatenate - Outer For statement
For T = 1 To 10 'This provides a rows reference to concatenate - Inner for statement
For Each Cell In Cells(T, Q) 'provides rows and column reference
If Cell.Value = "" Then GoTo Line1 'this tells the macro to continue until a blank cell is reached
x = x & Cell.Value & "," 'This provides the concatenated cell value and comma separator
Next ' this loops the range
Next T 'This is the inner loop which dynamically changes the number of rows to loop until a blank cell is reached
Line1:
On Error GoTo Terminate 'Terminates if there are less columns (max 10) to concatenate
ActiveCell.Value = Mid(x, 1, Len(x) - 1) 'This basically removes the last comma from the last concatenated cell e.g. you might get for a range 2,3,4, << this formula removes the last comma to
'give 2,3,4
ActiveCell.Offset(1, 0).Select 'Once the concatenated result is pasted into the cell this moves down to the next cell, e.g. from F1 to F2
x = "" 'The all important, clears x value after finishing concatenation for a range before moving on to another column and range
Next Q 'After one range is done the second column loop kicks in to tell the macro to move to the next column and begin concatenation range again
Terminate: 'error handler
End Sub
#Issun's solution doesn't accept output from a worksheet array formula as the argument for the 'cell_range' parameter. But a slight modification to #Issun's code fixes this. I also added a check that ignores each cell whose value is FALSE.
Function ConcatenateRange( _
ByVal cellArray As Variant, _
Optional ByVal seperator As String _
) As String
Dim cell As Range
Dim newString As String
Dim i As Long, j As Long
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
If (cellArray(i, j) <> False) Then
newString = newString & (seperator & cellArray(i, j))
End If
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function
For example:
A B (<COL vROW)
------ ------ -----------------
one 1 3
two 1 4
three 2 5
four 2 6
Enter into cell C1 the formula below and press CTRL+ENTER to store the formula as an array formula:
{=ConcatenateRange(IF(B3:B6=1,A3:A6),CHAR(10))}
I was looking further to see if there is a better way of writing concatenate function and found this. It seems that we all have the same working principle for the function. So its ok.
But my function is different that it can take multiple parameters, in combination of ranges, texts and numbers.
I assume that a delimiter is mandatory, so if i don't need it i just put "" as the last parameter).
I also assume that blank cells are not to be skipped. That's the reason why i want the function to take multiple parameters, so i can easily omit those that that i don't want in the concatenation.
Example of use:
=JoinText(A1:D2,F1:I2,K1:L1,";")
You can also use together text and number among the parameters:
=JoinText(A1:D2,123,F1:I2,K1:L1,"PQR",";")
I'd love to hear any comments or suggestions where it can be improved.
Here is the code.
Public Function JoinText(ParamArray Parameters() As Variant) As String
Dim p As Integer, c As Integer, Delim As String
Delim = Parameters(UBound(Parameters))
For p = 0 To UBound(Parameters) - 1
If TypeName(Parameters(p)) = "Range" Then
For c = 1 To Parameters(p).Count
JoinText = JoinText & Delim & Parameters(p)(c)
Next c
Else
JoinText = JoinText & Delim & Parameters(p)
End If
Next p
JoinText = Replace(JoinText, Delim, "", , 1, vbBinaryCompare)
End Function
Function ConcatenateRange to concatenate all cells in range if they are not empty and empty "" string.
Function ConcatenateRange(cellRange As Range, Optional Delimiter As String) As String
Dim cel As Range, conStr As String
conStr = ""
If Delimiter <> "" Then
For Each cel In cellRange
If VarType(cel) <> vbEmpty And Trim(cel) <> "" Then conStr = conStr & cel & Delimiter
Next
ConcatenateRange = Left(conStr, Len(conStr) - Len(Delimiter))
Else
For Each cel In cellRange
If VarType(cel) <> vbEmpty And Trim(cel) <> "" Then conStr = conStr & cel
Next
ConcatenateRange = conStr
End If
End Function
Its very simple brother, Look out of the Excel. No need for all cumbersome formula or VBA.
Just copy all the cells that you need to concatenate and paste it in the notepad. Now just select the space between the lines/columns (it's a TAB space actually) and find and replace it.. Done.. All cells are concatenated. Now just copy and paste it in the column and just verify.. Thats it :) Enjoy.
I suggest you to use Notepad++ for this :) Koodos
Vimarsh
Ph. D. Plant Biotech.
/
Below is a snippet of the table I'm working with.
From left to write I need to know how I can the entire second column appended to the first one. So, starting at V5789 of the second column, that and all of the contents below it need to be placed after the V854 in the first column. The third column needs to be 'stacked'onto the bottom of the second one. So 2 appends to 1, 3 appends to 2, 4 appends to 3. etc.
Any clues?
Hows this for an alternative? Only has 2 calls to the worksheet and one loop.
Sub append()
Dim g, newArray
Dim strJoin As String
Dim x As Integer
g = Sheet1.Cells(1, 1).CurrentRegion.Value
For x = 1 To UBound(g, 2)
strJoin = strJoin & Replace(Join(Application.Transpose(Application.Index(g, 0, x)), "~/"), "/~", "")
If Right(strJoin, 2) <> "~/" And x <> UBound(g, 2) Then strJoin = strJoin & "~/"
Next x
newArray = Split(strJoin, "~/")
Columns(1).Cells(1).Resize(UBound(newArray) + 1).Value = Application.Transpose(newArray)
End Sub
Try this:
Sub DoooooooooIT()
Dim col As Range, _
found As Range
Dim currRow As Integer
currRow = ActiveSheet.Range("A:A").Find("", after:=ActiveSheet.Range("A1"), lookat:=xlWhole, searchdirection:=xlNext).Row
For Each col In ActiveSheet.UsedRange.Columns
If col.Column <> 1 Then
Set found = col.EntireColumn.Find("", after:=col.Cells(1, 1), lookat:=xlWhole, searchdirection:=xlNext)
Set found = ActiveSheet.Range(col.Cells(1, 1), found)
found.Copy
ActiveSheet.Cells(currRow, 1).PasteSpecial
currRow = currRow + found.Cells.Count - 1
End If
Next col
End Sub
I would go about this by using 2 for loops: outer loop will start your counting variable at 2, then iterate up with a step of 1. This is iterating through your columns.
in that loop, have a nested for loop that iterates through each row of the unique columns. It will iterate from row one and down, checking each loop if the cell at the position given by the outer loop's column and inner loop's row has anything in it (so check if cell.value = ""). Once it finds the first empty cell in that column, have it copy everything from row 3 until the row counting variable in the outer loop's column and paste it into the previous column at row 3.
I have provided pseudo-code instead of the actual code because I don't believe this would be too difficult to write yourself and I don't have time to at this moment, so you may be able to do it sooner than I will have a chance too. However, if you want further assistance let me know and I can work on some code for you when I have a chance.
edit: forgot to add, make sure to include something to deal with the unique position of where the second column data needs to go into the first column. likely best if you just include something like "if PasteToColumn = 1 then paste into cell A9" or something similar
EDIT again: here's my new and improved version! let me know what you think/if it works
Sub MoveStuff()
Dim rowcounter As Integer
Dim columncounter As Integer
rowcounter = 1
columncounter = 2
Do While Cells(rowcounter, columncounter).Value <> ""
Do While Cells(rowcounter, columncounter).Value <> ""
rowcounter = rowcounter + 1
Loop
Range(Cells(3, columncounter), Cells(rowcounter - 1, columncounter)).Cut (Columns(columncounter - 1).End(xlDown).Offset(rowoffset:=1))
columncounter = columncounter + 1
rowcounter = 1
Loop
End Sub