VBA Error 13 Type Mismatch - vba

I am trying to add a line of cells in a sheet to a multicolumn listbox in a userform. The number of columns in the sheet also varies. I keep getting the error 'Type mismatch.' Stepping through my code I found that it occurs at the first .AddItem line. I found out that you cannot add multiple items with .AddItem. Is there another method to do this? I'm very new to vba. Thanks for your help!
Private Sub GenerateButton_Click()
Dim i As Long, counter As Long, counter_RA As Long, x As Integer
Dim LastColRA As Long, LastColCP As Long
LastColRA = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
LastColCP = Sheet2.Cells(1, Columns.Count).End(xlToLeft).Column
'Check to make sure that enough items were selected
For x = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(x) Then
counter_RA = counter_RA + 1
With TabData.DataTable
.AddItem Sheets(Sheet1).Range(Cells(x + 2, 1), Cells(x + 2, LastColRA)).Text
End With
End If
Next x
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) Then
counter = counter + 1
With TabData.DataTable
.AddItem Sheets(Sheet2).Range(Cells(i + 2, 1), Cells(i + 2, LastColCP)).Text
End With
End If
Next i
End Sub

You have a couple of issues there. First, if you use the Text property of a multiple cell range, it will return Null unless all the cells contain the same text. Second, as you note, you cannot add an array in one go using AddItem - you need to add an item then loop to populate the columns, remembering that the indices are 0-based:
With TabData.DataTable
.AddItem
For n = 1 to LastColRA
.List(.ListCount - 1, n - 1) = Sheet1.Cells(x + 2, n).Value
next n
End With
Here's a version that will work with more than 10 columns:
Dim i As Long, counter As Long, counter_RA As Long, x As Long
Dim LastColRA As Long, LastColCP As Long
Dim vList()
LastColRA = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
LastColCP = Sheet2.Cells(1, Columns.Count).End(xlToLeft).Column
'Check to make sure that enough items were selected
For x = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(x) Then
counter_RA = counter_RA + 1
ReDim Preserve vList(1 To LastColRA, 1 To counter_RA)
For i = 1 To LastColRA
vList(i, counter_RA) = Sheet1.Cells(x + 2, i).Value
Next i
End If
Next x
For x = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(x) Then
counter_RA = counter_RA + 1
ReDim Preserve vList(1 To LastColRA, 1 To counter_RA)
For i = 1 To LastColRA
vList(i, counter_RA) = Sheet2.Cells(x + 2, i).Value
Next i
End If
Next x
With TabData.DataTable
.ColumnCount = LastColRA
.Column = vList
End With

Related

I have a problem that does not generate the correct sequence?

An analyst observed that the upward movement of stocks on Bovespa is repeated according to a mathematical sequence. He wants to find out what the next bullish sequences will be. Generate and save in Excel cells using macro the sequence 1, 3, 4, 7, 11, 18, 29, ... up to its twentieth term?
following my code in vba:
Sub GerarSequencia()
Dim num As Long
Dim previous As Long
Dim i As Integer
num = 0
previous = 0
For i = 1 To 20
If i = 1 Then
num = 1
Else
num = num + previous
End If
Cells(i, 1).Value = num
previous = num
Next i
End Sub
I tried to generate the sequence of the exercise but did it generate another one?
The sequence is a sommation of the earlier two values. So 1 + 3 = 4 and so on. Before you can start the sqequence you have to have two numbers. I think you can work with:
Sub GerarSequencia()
Dim intFirstNum, intSecondNum As Integer
Dim intCounter As Integer
intFirstNum = 1
intSecondNum = 3
Cells(1, 1) = intFirstNum
Cells(2, 1) = intSecondNum
For intCounter = 3 To 20
Cells(intCounter, 1).Value = Cells(intCounter - 2, 1).Value + Cells(intCounter - 1, 1).Value
Next intCounter
End Sub
So you see that I have made two additional variables which are filled with 1 and 3 (if you change them you can start wherever you want). From that point on, I start the loop from position 3. This is because the first two are already known.
From that point on you can run the sequence. You don't need an if statement in that case.
Generating a Sequence
Sub GerarSequencia()
Const nCOUNT As Long = 20
Dim nPrev As Long: nPrev = 1
Dim nCurr As Long: nCurr = 3
Cells(1, 1).Value = nPrev
Cells(2, 1).Value = nCurr
Dim nNext As Long
Dim i As Long
For i = 3 To nCOUNT
nNext = nPrev + nCurr ' sum up
Cells(i, 1).Value = nNext ' write
nPrev = nCurr ' swap
nCurr = nNext ' swap
Next i
' ' Return the worksheet results in the Immediate window (Ctrl + G).
' For i = 1 To 20
' Debug.Print Cells(i, 1).Value
' Next i
End Sub

VBA Permutate 1D array adding set value to each array item n number of times

I am trying to figure out a loop logic to get all possible permutations where I add a set value to each item in a set array iLoop number of times. I'm gonna try my best to explain what I am looking for.
I have a set value "StrokeValue" and a set array "DistanceMatesArray"
Dim StrokeValue as single
Dim DistanceMatesArray as variant
StrokeValue = 300
DistanceMatesArray = Array(300, 300, 300, 300)
Now I need to loop through each possible result where I add StrokeValue to each Item which in the first loop would result in possible DistanceMatesArrays:
The tricky part is when I want to add StrokeValue more than once and get every outcome where I added StrokeValue iLoop number of time "AllowedActions" resulting in a list such as:
I kind of suspect that I need a 2D array to store all the results from previous loop., that's why in the example the rows are coloured to indicate which one row was taken as a starting point to add the StrokeValue once
What I got so far looks like this:
Public StrokeValue As Single
Public DistanceMatesArray As Variant
Public iError As Long
Public NumberOfCombinations As Long
Public x As Long
Public y As Long
Public i As Long
Option Explicit
Sub Test()
'Declare variables
Dim PreviousLoopResultsArray As Variant
Dim NextLoopResultsArray As Variant
Dim iresults As Long
Dim iLoop As Long
Dim iPreviousResult As Long
'Set variables
StrokeValue = 300
'Array
DistanceMatesArray = Array(300, 300, 300, 300)
ReDim NextLoopResultsArray(0, UBound(DistanceMatesArray))
For i = LBound(DistanceMatesArray) To UBound(DistanceMatesArray)
NextLoopResultsArray(0, i) = DistanceMatesArray(i)
Next i
'------------------------------------------------------
'Loop
Do While iError = NumberOfCombinations
'Try DistanceMatesArray
For i = 0 To iresults
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
DistanceMatesArray(x) = NextLoopResultsArray(i, x)
Next x
Debug.Print Join(DistanceMatesArray)
'TRY HERE
Next i
'Array
PreviousLoopResultsArray = NextLoopResultsArray
'Array
If iLoop <> 0 Then
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
DistanceMatesArray(x) = PreviousLoopResultsArray(iPreviousResult, x)
Next x
End If
'Set variables
iLoop = iLoop + 1
iPreviousResult = 1
iresults = ((UBound(DistanceMatesArray) + 1) ^ iLoop) - 1
ReDim NextLoopResultsArray(iresults, UBound(DistanceMatesArray))
'Populate NextLoopResultsArray
For y = 0 To iresults 'Loop vertically
If y Mod (UBound(DistanceMatesArray) + 1) = 0 And y <> iresults And y <> 0 Then
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
DistanceMatesArray(x) = PreviousLoopResultsArray(iPreviousResult, x)
Next x
iPreviousResult = iPreviousResult + 1
End If
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
NextLoopResultsArray(y, x) = DistanceMatesArray(x)
With ThisWorkbook.Worksheets(1).Cells(y + 1, x + 1)
.Value = NextLoopResultsArray(y, x)
End With
Next x
Next y
'Modify NextLoopResultsArray
x = 0
For y = 0 To iresults 'Loop vertically
NextLoopResultsArray(y, x) = NextLoopResultsArray(y, x) + StrokeValue
With ThisWorkbook.Worksheets(1).Cells(y + 1, x + 1)
.Value = NextLoopResultsArray(y, x)
.Interior.Color = vbYellow
End With
If x + 1 > UBound(DistanceMatesArray) Then
x = 0
Else
x = x + 1
End If
Next y
'Set variables
iPreviousResult = 0
'Excel reset
For i = 1 To (UBound(DistanceMatesArray) + 1)
Columns(i).Clear
Next i
Loop
End Sub
At the end of the loop I am expecting to have each one row as DistanceMatesArray i.e. one of them would now be
DistanceMatesArray = array(300,600,600,300)
Where it added StrokeValue twice.
Would someone, please, help me figure out a shorter and simpler logic behind this?
EDIT:
Results expected after running it up to 3 loops looks like this:
And without duplicate outcomes
Continuing to try and figure out the logic of it, maybe now someone get's a betetr idea for what I am lookign for and can help
No need to mention that it's an infinite loop - I know that and That's the point, it needs to go on untill I validate the right array in which case iError <> NumberOfCombinations.
Been able to learn more about arrays, so I consider this a big win.
The code took in account the duplicates but for now your iterations are hardset (could easily ask how many iterations with an inputbox), not in the endless loop you had set up, hope that rework won't be too much.
Some variables are reworked, I tried to keep most of your original ones though.
Public StrokeValue As Single
Public DistanceMatesArray As Variant
Public iError As Long
Public iTerations As Long
Public i As Long
Public j As Long
Public k As Long
Option Explicit
Sub TestArrayfill()
Dim pArray As Variant, nArray As Variant, cArray As Variant 'pArray = previous array, nArray = next array, cArray = check array
Dim iresults As Long, iLoop As Long, nb As Long, actB As Long, addCounter As Long, Lastrow As Long
'Set variables
StrokeValue = 300
addCounter = 1
iTerations = 4
'Array
DistanceMatesArray = Array(300, 300, 300, 300)
nb = UBound(DistanceMatesArray) + 1
ReDim Preserve DistanceMatesArray(1 To nb)
cArray = DistanceMatesArray
ReDim pArray(1 To nb, 1 To nb)
For i = 1 To nb
pArray(1, i) = DistanceMatesArray(i)
Next i
actB = nb
For iLoop = 1 To iTerations 'I can't figure out the limitations with permutations so we'll just bruteforce it with nb*actB (maximum possibilities)
ReDim nArray(1 To nb * actB, 1 To nb) '(re)setting nArray
If iLoop = 1 Then actB = 1 'workaround to have pArray as a 2D-array
For i = 1 To actB 'loop through every row in pArray except for when iLoop = 1
For j = 1 To nb 'loop through every cell in pArray(i)
For k = 1 To nb 'setting the extra StrokeValue
If j = k Then
cArray(k) = pArray(i, k) + StrokeValue
Else
cArray(k) = pArray(i, k)
End If
Next k
If Not arrElemInArray(cArray, nArray) Then
For k = 1 To nb
nArray(addCounter, k) = cArray(k) 'add the "row" to our nArray
Next k
addCounter = addCounter + 1
End If
Next j
Next i
actB = addCounter - 1
ReDim pArray(1 To actB, 1 To nb) 'ReDim is possible on both dimensions, Redim Preserve is not so we use this to our advantage
For i = 1 To actB 'another loop is necessary however
For j = 1 To nb
pArray(i, j) = nArray(i, j)
Next j
Next i
' nArray = Application.Transpose(nArray)
' ReDim Preserve nArray(1 To nb, 1 To actB)
' nArray = Application.Transpose(nArray)
' pArray = Application.Transpose(pArray)
' ReDim pArray(1 To UBound(nArray, 2), UBound(nArray, 1))
' pArray = Application.Transpose(pArray)
' pArray = nArray
addCounter = 1
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
If Lastrow = 1 Then
Cells(Lastrow, 1).Value = "Loop" & iLoop
Else
Cells(Lastrow + 1, 1).Value = "Loop " & iLoop
Lastrow = Lastrow + 1
End If
Cells(Lastrow + 1, 1).Resize(UBound(nArray, 1), UBound(nArray, 2)) = nArray
Next iLoop
End Sub
Function arrElemInArray(arr As Variant, arrX As Variant) As Boolean 'this is from one of your previous questions btw, just a bit modified to fit our needs
Dim i As Long, j As Long, boolFound As Boolean, mtch
If Not IsArray(arrX) Then
For j = LBound(arr) To UBound(arr)
If arr(j) = arrX Then arrElemInArray = True: Exit For
Next j
Exit Function
End If
For i = LBound(arrX) To UBound(arrX)
boolFound = True 'True at beginning so if any cells deviates from the corresponding check, it gets set to False, ergo it doesn't exist yet.
For j = LBound(arr) To UBound(arr)
If arr(j) <> arrX(i, j) Then
boolFound = False
End If
Next j
If boolFound Then arrElemInArray = True: Exit Function
Next i
arrElemInArray = False
End Function
Hope it's all clear and works for you :)
I understood your logic for the first table
but for the following ones I find it difficult to understand what you want especially in relation to the capture that you put in your message
for the first
Sub testing()
Dim StrokeValue As Single
Dim DistanceMatesArray As Variant
Dim i As Long 'variable row iteration
Dim c As Long 'variable column itération
Dim Table As Variant 'variable variant no dimention in the first
StrokeValue = 300
DistanceMatesArray = Array(300, 300, 300, 300) 'is an array in base 0
nb = UBound(DistanceMatesArray) + 1 'convert a ubound of DistanceMatesArray in count (in base 1)
ReDim Table(1 To nb, 1 To nb) 'table dimensioning (variant) in base 1
'loop for row
For i = 1 To UBound(Table) 'start at index 1
'loop for column
For c = 1 To UBound(Table, 2) 'start at index 1
'if index row and index column then item has multipled by (2)
If c <> i Then Table(i, c) = StrokeValue Else Table(i, c) = StrokeValue + StrokeValue
Next c
Next i
'just for see on sheet
Cells.Resize(UBound(Table), UBound(Table)) = Table
End Sub

Fixed Columns to Row

Have data spread across columns
Want to keep the first three columns fixed (columns a, b and c).
And convert columns from four onward into new rows (columns d --> last column where there is a value).
Example:
The colours from columns D -->onwards are NOT always green, blue, black red, etc.... they vary depending on the data loaded in from a power query table.
This is how I want the data to look:
Notice how columns A, B and C are fixed with the same info and only columns D onwards is recreating a new "row".
I've been trying to adapt a VBA script from a previous post on here, but I'm having some complications. I'm also trying to keep it on the sheet that the data is currently on, not create a new sheet. If it is easier to just create a new sheet.. then I can work with that.. Script:
Sub ColumnTorow()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
With ActiveSheet
Dim rRow As Long
rRow = 2
Dim row As Long
row = 2
Dim col As Integer
Do While True
col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks
.Cells(rRow, 1).Value = data(row, 1)
.Cells(rRow, 2).Value = data(row, col)
rRow = rRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop
If row = maxRows Then Exit Do 'exit cluase
row = row + 1
Loop
End With
End Sub
This is just an example code that I was provided with and I'm trying to modify... It might not even be the correct solution to this problem but figured I would post it anyways.
Here you go, since I did this yesterday, I got it together fairly quickly:
Sub ColumnToRow()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
Dim newSht As Worksheet
Set newSht = Sheets.Add
With newSht
.Cells(1, 1).Value = data(1, 1)
.Cells(1, 2).Value = data(1, 2)
.Cells(1, 3).Value = data(1, 3)
.Cells(1, 4).Value = data(1, 4)
Dim writeColumn As Double
writeColumn = 1
Dim writeRow As Double
writeRow = 2
Dim row As Double
row = 2
Do
writeColumn = 1
Dim col As Double
col = 4
Do While True
If data(row, col) <> "" Then
Dim firstColData As String
firstColData = data(row, 1)
.Cells(writeRow, writeColumn) = firstColData
writeColumn = 2
Dim secondColData As String
secondColData = data(row, 2)
.Cells(writeRow, writeColumn) = secondColData
writeColumn = 3
Dim thirdColData As String
thirdColData = data(row, 3)
.Cells(writeRow, writeColumn) = thirdColData
writeColumn = 4
.Cells(writeRow, writeColumn).Value = data(row, col)
writeColumn = 1
writeRow = writeRow + 1
End If
If col = maxCols Then
Exit Do 'Exit clause
End If
col = col + 1
Loop
If row = maxRows Then
Exit Do 'exit cluase
End If
row = row + 1
Loop While True
End With
End Sub
consider this code.
Sub TransData()
Dim vDB, vR()
Dim n As Long, i As Long, j As Integer, k As Integer
vDB = Range("a1").CurrentRegion
For i = 2 To UBound(vDB, 1)
For j = 4 To UBound(vDB, 2)
If vDB(i, j) <> "" Then
n = n + 1
ReDim Preserve vR(1 To 4, 1 To n)
For k = 1 To 3
vR(k, n) = vDB(i, k)
Next k
vR(4, n) = vDB(i, j)
End If
Next j
Next i
Sheets.Add
Range("a1").Resize(1, 4) = Array("Item", "Amount", "Price", "Color")
Range("a2").Resize(n, 4) = WorksheetFunction.Transpose(vR)
End Sub

VBA Return Carriage and Fill Code

I'm really new to vba and would appreciate any assistance in the following problem I'm having.
Problem description (in relation to diagram below):
1*) In c, I have managed to separate the return carriages, which leads to 2*) now that each return carriage has it's own row, I need column b and c on either side to be filled down as shown in result 3*)
1*) b c e
y 1,2,3,4 y
z 5,6,7,8 z
2*) b c e
y 1 y
2
3
4
z 5 z
6
7
8
3*) b c e
y 1 y
y 2 y
y 3 y
y 4 y
z 5 z
z 6 z
z 7 z
z 8 z
I have included my original code for everyone to inspect, I am currently stuck as to how I would get to step 3.
Sub InString()
Dim rColumn As Range 'Set this to the column which needs to be worked through
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lRow As Long 'Difference between first and last row
Dim lLFs As Long
Dim rRow As Range 'This will be used to drag the fill down between rows
Set rColumn = Columns("N")
lFirstRow = 2 'Starting may need to be adjusted, if additional columns are added
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).Row
For lRow = lLastRow To lFirstRow Step -1
lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, ""))
If lLFs > 0 Then
rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert shift:=xlShiftDown 'added EntireRow to before insert, to bring whole row down, instead of previous issue where only rColumn was shifted down.
rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf))
End If
Next lRow
End Sub
Thanks,
I just added a loop at the end looking for blanks -
Sub InString()
Dim rColumn As Range 'Set this to the column which needs to be worked through
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lRow As Long 'Difference between first and last row
Dim lLFs As Long
Dim rRow As Range 'This will be used to drag the fill down between rows
Dim strVal As String
Set rColumn = Columns("N")
lFirstRow = 2 'Starting may need to be adjusted, if additional columns are added
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).row
For lRow = lLastRow To lFirstRow Step -1
lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, ""))
If lLFs > 0 Then
rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert shift:=xlShiftDown 'added EntireRow to before insert, to bring whole row down, instead of previous issue where only rColumn was shifted down.
rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf))
End If
Next lRow
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).row
Dim rColNum As Integer
rColNum = rColumn.Column
For i = 2 To lLastRow
If Cells(i, rColNum - 1) = "" Then
Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1)
Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1)
End If
Next
End Sub
Basically this part -
For i = 2 To lLastRow
If Cells(i, rColNum - 1) = "" Then
Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1)
Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1)
End If
Next
Says, look at each row in the column we just split and see if the cell to the left is blank. If it is, make it the same as the one above it AND make the cell to the right the same as the one above it.
To expand, you might then say
if Cells(i, rColNum - 1) = "" Then
Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1)
Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1)
Cells(i, rColNum - 2) = Cells(i - 1, rColNum - 2)
Cells(i, rColNum + 2) = Cells(i - 1, rColNum + 2)
End If
If you wanted to cover the adjacent two columns on either side of rcolumn.
Assuming your input data is in columns B, D and E (as your diagram suggests) then this does the job I think:
Sub OrderData()
Dim inputData As Range, temp() As Variant, splitData As Variant, i As Integer, j As Integer, rw As Long
Set inputData = Range("B1:E2") //Update to reflect your data
temp = inputData.Value
inputData.ClearContents
rw = 1
For i = 1 To UBound(temp)
splitData = Split(temp(i, 2), ",")
For j = 0 To UBound(splitData)
Cells(rw, 2) = temp(i, 1)
Cells(rw, 3) = splitData(j)
Cells(rw, 5) = temp(i, 4)
rw = rw + 1
Next j
Next i
End Sub

VBA: How to transform a one column full dictionary into one column per letter?

I have a full dictionary. All the words (360 000) are in one column.
I'd like to have Column B with all words starting with "a", column C with all words starting with b...
I am trying to do a loop or something... but... It is just too long.
Any tips? Or did someone already do this vba macro?
Tks,
Stéphane.
If we start with:
Running this short macro:
Sub SeparateData()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
End Sub
will produce:
NOTE:
You may want to add some error capture logic to the NewCol calculation line.
EDIT#1:
This version may be slightly faster:
Sub SeparateDataFaster()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long, time1 As Date, time2 As Date
N = Cells(Rows.Count, 1).End(xlUp).Row
time1 = Now
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
time2 = Now
MsgBox time1 & vbCrLf & time2
End Sub
You can try something like this.
For 360k records its take about 20sec.
To create tests data i use this sub:
Sub FillTestData()
Dim t As Long
Dim lng As Integer
Dim text As String
'Start = Timer
For t = 1 To 360000
text = vbNullString
lng = 5 * Rnd + 10
For i = 1 To lng
Randomize
text = text & Chr(Int((26 * Rnd) + 65))
Next i
Cells(t, 1) = text
Next t
'Debug.Print Timer - Start
End Sub
And for separate:
Sub sep()
'Start = Timer
Dim ArrWords() As Variant
Dim Row_ As Long
LastRow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ArrWords = Range("A1:A" & LastRow) 'all data from column A to array
For i = 65 To 90 ' from A to Z
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) = i Then
Cells(Row_, i - 63) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
Next i
'other than a[A]-z[Z]
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) < 65 Or Asc(UCase(ArrWords(j, 1))) > 90 Then
Cells(Row_, 28) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
'Debug.Print Timer - Start
End Sub
You could try:
For i = 1 To Cells(Rows.count, 1).End(xlUp).Row
Range(UCase(Left$(Cells(i, 1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Offset(IIf(Range(UCase(Left$(Cells(i, _
1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Row = 1, 0, 1), 0).Value = Cells(i, 1).Text
Next i
Which is just building the destination address using the first letter of the word by doing the following:
Loop through each cell in column A
Get the first letter of that cell and convert it to upper case
Find the last cell in the column starting with that letter
Move over 1 column to the right
Go up until we hit the last row of data
If the last row isn't row 1, move down another row (next blank cell)
Give this cell the same value as the cell in column A that we're assessing
You can enter the following formula:
For letter A in B Column:
=IF(UPPER(LEFT(A1,1))="A",A1,"")
For letter B in C Column:
=IF(UPPER(LEFT(A1,1))="B",A1,"")
Repeat the same for letter C, D and so on..