I'm using VBA to calculate pairwise slopes, store them in an array, then using Chip Pearson's technique of transposing the array on a workheet to sort them. My code fails when the number of slopes exceeds 65K, which would make sense in Excel 2003, due to number of rows. I thought it would work in Excel 2010, but I seem to have the same issue. Does anyone know if there's limitations to the Resize property or Transpose method?
Thanks
Sub pairwise()
Dim endrow As Long, i As Long, j As Long, s As Long
Dim num As Double, denom As Double, sij As Double
Dim r As Range
Dim slopes()
endrow = Range("A1").End(xlDown).Row
n = endrow - 1
nrd = endrow * n / 2
ReDim slopes(nrd)
Debug.Print LBound(slopes); UBound(slopes)
For i = 1 To n
For j = (i + 1) To endrow
num = Cells(i, 2).Value - Cells(j, 2).Value
denom = Cells(i, 1).Value - Cells(j, 1).Value
If denom <> 0 Then
sij = num / denom
slopes(s) = sij
s = s + 1
End If
Next j
Next i
Set r = Range("C1").Resize(UBound(slopes) - LBound(slopes) + 1, 1)
r = Application.Transpose(slopes)
' sort the range
r.Sort key1:=r, order1:=xlAscending, MatchCase:=False
End Sub
I found the same limitation on the INDEX function. http://dailydoseofexcel.com/archives/2013/10/11/worksheetfunction-index-limitations/
Here's how you can make the output array a two dimensional array and read in all the values at once rather than inside a loop.
Sub pairwise()
Dim lEndRow As Long
Dim vaValues As Variant
Dim aSlopes() As Variant
Dim lCnt As Long
Dim rOutput As Range
Dim i As Long, j As Long
'A 2d array here can easily be written to a sheet
lEndRow = Sheet3.Range("a1").End(xlDown).Row
ReDim aSlopes(1 To lEndRow * (lEndRow - 1), 1 To 1)
'Create a two-d array of all the values
vaValues = Sheet3.Range("A1").Resize(lEndRow, 2).Value
'Loop through the array rather than the cells
For i = LBound(vaValues, 1) To UBound(vaValues, 1) - 1
For j = 1 + 1 To UBound(vaValues, 1)
If vaValues(i, 1) <> vaValues(j, 1) Then
lCnt = lCnt + 1
aSlopes(lCnt, 1) = (vaValues(i, 2) - vaValues(j, 2)) / (vaValues(i, 1) - vaValues(j, 1))
End If
Next j
Next i
'Output the array to a range, and sort
Set rOutput = Sheet3.Range("C1").Resize(UBound(aSlopes, 1), UBound(aSlopes, 2))
rOutput.Value = aSlopes
rOutput.Sort rOutput.Cells(1), xlAscending, , , , , , , , False
End Sub
It a limitation of the Transpose method.
My suggestion would be to declare your array as 2D from the start
Redim Slopes(1 To nrd, 1 To 1)
Also, your should use the Variant Array approach instead of looping over cells in your For loop
Related
So currently, per the title, I'm looking to make a smart and relatively automatic transpose system.
So far the only way I've figured out how to do this is with macros, paste special, and a lot of manual work (working on 2,000~ row sheet).
The following example is an example.
All the events belong to A1 but are distributed downwards in a new row. The goal is to have them all in a single row (either in a single cell or adjacent).
A Event 1
A Event 2
A Event 3
B Group 1
B Group 2
All the events belong to A1 but are distributed downwards in a new row. The goal is to have them all in a single row (either in a single cell or adjacent).
The example of how I need them is demonstrate below.
A Event 1 Event 2 Event 3
B Group 1 Group 2
I have searched far and wide and haven't found anything which solves this bizarre request.
You can do this quite easily using a dictionary. Have a look at the following. You will need to update the two With blocks with your input and destination range
Public Sub test()
Dim dict As Object
Dim arr As Variant, tmp As Variant
Dim i As Long
Dim key
Set dict = CreateObject("Scripting.Dictionary")
' Source Data
With Sheet1
arr = .Range(.Cells(1, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "B")).Value2
End With
For i = LBound(arr, 1) To UBound(arr, 1)
If Not IsEmpty(tmp) Then Erase tmp
If dict.exists(arr(i, 1)) Then
tmp = dict(arr(i, 1))
ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
tmp(UBound(tmp)) = arr(i, 2)
dict(arr(i, 1)) = tmp
Else
ReDim tmp(0)
tmp(LBound(tmp)) = arr(i, 2)
dict.Add key:=arr(i, 1), Item:=tmp
End If
Next i
' Destination
With Sheet1.Cells(1, 5)
i = 0
For Each key In dict.keys
.Offset(i, 0) = key
'' Side by side
Range(.Offset(i, 1), .Offset(i, UBound(dict(key)) + 1)).Value2 = dict(key)
'' In one cell
'.Offset(i, 1).Value2 = Join(dict(key), ",")
i = i + 1
Next key
End With
End Sub
Say we have data in columns A and B like:
Running this code:
Sub Macro1()
Dim Na As Long, Nd As Long, rc As Long
Dim i As Long, j As Long, K As Long
Dim v As Variant
Range("A:A").Copy Range("D:D")
Range("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
rc = Rows.Count
K = 5
Na = Cells(rc, "A").End(xlUp).Row
Nd = Cells(rc, "D").End(xlUp).Row
For i = 1 To Nd
v = Cells(i, "D")
For j = 1 To Na
If v = Cells(j, 1) Then
Cells(i, K) = Cells(j, 2)
K = K + 1
End If
Next j
K = 5
Next i
End Sub
will produce:
I want to break selection (B3, B4..etc) into new row.. Please help me.
for a example= If I select B3 cell, I wanna add more 3 Rows and 2nd to 4th line should be move down. Always not same line break in each cell.
Splitting the cell into an array of strings is simple with excel-vba using the Split function.
If cell A1 contains a string with Chr(10)'s (LF/Linefeed characters) then you could split it into an array with VBA like this:
Dim myArr() as String
myArr = Split(Range("A1"), Chr(10))
...then you could dump it into a range of cells horizontally (with the help of UBound) like this:
Dim startColumn As Integer
startColumn = 2
Range(Cells(1, startColumn), Cells(1, startColumn + UBound(myArr))) = myArr()
...or you could dump it into a range of cells vertically like this:
Dim startRow As Integer, x As Integer
startRow = 2
For x = 0 To UBound(myArr)
Range("A" & x + startRow) = myArr(x)
Next x
You haven't shared the code you've tried so far, but I trust you'll should be able to handle the "inserting rows" part with Range.Insert, or a quick Google Search (if you don't already know how).
use split function and variant array.
Sub test()
Dim vSplit
Dim vDB, vR()
Dim i As Long, n As Long, j As Integer
vDB = Range("a1").CurrentRegion
For i = 1 To UBound(vDB, 1)
vSplit = Split(vDB(i, 2), Chr(10))
For j = 0 To UBound(vSplit)
n = n + 1
ReDim Preserve vR(1 To 3, 1 To n)
If j = 0 Then
vR(1, n) = vDB(i, 1)
vR(3, n) = vDB(i, 3)
End If
vR(2, n) = vSplit(j)
Next j
Next i
Sheets.Add
Range("a1").Resize(n, 3) = WorksheetFunction.Transpose(vR)
End Sub
I was wondering if someone can help me with the following,
In VBA in Excel, I have the following table :
Column 1|Column2|Column3|Column4|Column5|Column6
---------|---------|---------|---------|---------|---------
1.2.3.4|Apple%Car|Canada%USA|Tomatoes|Hotel|Montreal%Paris%New-York
1.3.4.6|Cat%Uniform%Dog|France|Ananas|Motel|Amsterdam%San-Diego
And I would like to convert this in Excel using VBA into the following table :
Column 1|Column 2|Column 3|Column 4|Column 5|Column 6
:---------:|:---------:|:---------:|:---------:|:---------:|:---------:
1.2.3.4|Apple|Canada|Tomatoes|Hotel|Montreal
1.2.3.4|Apple|Canada|Tomatoes|Hotel|Paris
1.2.3.4|Apple|Canada|Tomatoes|Hotel|New-York
1.2.3.4|Apple|USA|Tomatoes|Hotel|Montreal
1.2.3.4|Apple|USA|Tomatoes|Hotel|Paris
1.2.3.4|Apple|USA|Tomatoes|Hotel|New-York
1.2.3.4|Car|Canada|Tomatoes|Hotel|Montreal
1.2.3.4|Car|Canada|Tomatoes|Hotel|Paris
1.2.3.4|Car|Canada|Tomatoes|Hotel|New-York
1.2.3.4|Car|USA|Tomatoes|Hotel|Montreal
1.2.3.4|Car|USA|Tomatoes|Hotel|Paris
1.2.3.4|Car|USA|Tomatoes|Hotel|New-York
1.3.4.6|Cat|France|Ananas|Motel|Amsterdam
1.3.4.6|Cat|France|Ananas|Motel|San-Diego
1.3.4.6|Uniform|France|Ananas|Motel|Amsterdam
1.3.4.6|Uniform|France|Ananas|Motel|San-Diego
1.3.4.6|Dog|France|Ananas|Motel|Amsterdam
1.3.4.6|Dog|France|Ananas|Motel|San-Diego
Does anyone have an idea how to do this ?
Thank you !
To get my brain going I bit. This does more or less what you want (However there is room for improvement as it currently can produce duplicate rows which it then removes at the end. I've missed something but as you haven't tried anything I haven't put any more effort in figuring out where this is happening exactly).
You'll also have to change the Ranges for where your inputs and outputs come from in the ConvertToTable sub. This uses a recursive function (i.e. one that calls itself) to populate your output
Option Explicit
Public Sub ConvertToTable()
Dim data As Variant, tmp() As Variant
Dim arr() As Variant
Dim i As Long
Dim c As Range
With Sheet2
data = Range(.Cells(1, 1), .Cells(2, 6)).Value2
End With
For i = LBound(data, 1) To UBound(data, 1)
tmp = Application.Index(data, i, 0)
arr = PopulateResults(tmp, "%", arr)
Next i
With Sheet4
With .Range(.Cells(1, 1), .Cells(UBound(arr, 2), UBound(arr, 1)))
.Value2 = Application.Transpose(arr)
.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlNo
End With
End With
End Sub
Public Function PopulateResults(tmp As Variant, delimiter As String, Results() As Variant) As Variant()
Dim i As Long, j As Long
Dim DelCount As Long, MaxDel As Long
Dim tmp2 As Variant
On Error Resume Next
i = UBound(Results, 2) + 1
If i = 0 Then i = 1
On Error GoTo 0
ReDim Preserve Results(1 To UBound(tmp), 1 To i)
For j = 1 To UBound(tmp)
Results(j, i) = tmp(j)
If InStr(1, tmp(j), delimiter, vbTextCompare) Then
DelCount = 0
Results(j, i) = Split(tmp(j), delimiter)(DelCount)
Do
DelCount = DelCount + 1
tmp2 = tmp
tmp2(j) = Split(tmp(j), delimiter)(DelCount)
Results = PopulateResults(tmp2, delimiter, Results)
Loop Until DelCount = Len(tmp(j)) - Len(Replace(tmp(j), delimiter, vbNullString))
End If
Next j
PopulateResults = Results
End Function
Thank you very much, It is much appreciated. Sorry for the delay, I didn't get any e-mail notification for the response.
I played with the source code and I have the following, it works for all the column that contain short value.. :
'Transform the data
Dim data As Variant, tmp() As Variant
Dim arr() As String
Dim i As Long
Dim c As Range
With Aggregation_Source
data = Range(Cells(1, 1), Cells(2, 8)).Value2
End With
For i = LBound(data, 1) To UBound(data, 1)
tmp = Application.Index(data, i, 0)
arr = PopulateResults(tmp, "%", arr)
Next i
With Aggregation_Source
With Range(Cells(1, 1), Cells(UBound(arr, 2), UBound(arr, 1)))
.Value2 = Application.Transpose(arr)
.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlNo
End With
End With
End Sub
Public Function PopulateResults(tmp As Variant, delimiter As String, Results() As String) As String()
Dim i As Long, j As Long
Dim DelCount As Long, MaxDel As Long
Dim tmp2 As Variant
On Error Resume Next
i = UBound(Results, 2) + 1
If i = 0 Then i = 1
On Error GoTo 0
ReDim Preserve Results(1 To UBound(tmp), 1 To i)
For j = 1 To UBound(tmp)
Results(j, i) = tmp(j)
If InStr(1, tmp(j), delimiter, vbTextCompare) Then
DelCount = 0
Results(j, i) = Split(tmp(j), delimiter)(DelCount)
Do
DelCount = DelCount + 1
tmp2 = tmp
tmp2(j) = Split(tmp(j), delimiter)(DelCount)
Results = PopulateResults(tmp2, delimiter, Results)
Loop Until DelCount = Len(tmp(j)) - Len(Replace(tmp(j), delimiter, vbNullString))
End If
Next j
PopulateResults = Results
End Function
Now, I think that the code crash because I have one column that contains two long text separated by % more than a 1000 characters, I will try to change the type for arr() to see if it works but I think I am missing something in the code .
Question is about sorting data in VBA. Suppose I have a Range("A1:A10") which I want to sort in ascending order. However, I do not want any changes in my spreadsheet (so all the calculations are made within a VBA code). The output of the operation should be a NewRange where all the numbers are sorted.
Has someone ideas about this problem?
Here is a very simple little routine to sort a two-dimensional array such as a range:
Option Base 1
Option Explicit
Function SortThisArray(aryToSort)
Dim i As Long
Dim j As Long
Dim strTemp As String
For i = LBound(aryToSort) To UBound(aryToSort) - 1
For j = i + 1 To UBound(aryToSort)
If aryToSort(i, 1) > aryToSort(j, 1) Then
strTemp = aryToSort(i, 1)
aryToSort(i, 1) = aryToSort(j, 1)
aryToSort(j, 1) = strTemp
End If
Next j
Next i
SortThisArray = aryToSort
End Function
How to use this sort function:
Sub tmpSO()
Dim aryToSort As Variant
aryToSort = Worksheets(1).Range("C3:D9").Value2 ' Input
aryToSort = SortThisArray(aryToSort) ' sort it
Worksheets(1).Range("G3:H9").Value2 = aryToSort ' Output
End Sub
Notes:
The range sorted here is on Worksheet(1) in the Range("C3:D9") and the output is going on the same sheet into Range("G3:H9")
The range will be sorted in ascending order.
The range will be sorted based on the first column (here column C). If you wish to sort for another column then you just have to change all the aryToSort(i, 1) and aryToSort(j, 1) to which ever column you wish to sort. For example by column 2: aryToSort(i, 2) and aryToSort(j, 2).
UPDATE:
If you prefer to use the above as a function then this is also possible like this:
Option Base 1
Option Explicit
Function SortThisArray(rngToSort As range)
Dim i As Long
Dim j As Long
Dim strTemp As String
Dim aryToSort As Variant
aryToSort = rngToSort.Value2
For i = LBound(aryToSort) To UBound(aryToSort) - 1
For j = i + 1 To UBound(aryToSort)
If aryToSort(i, 1) > aryToSort(j, 1) Then
strTemp = aryToSort(i, 1)
aryToSort(i, 1) = aryToSort(j, 1)
aryToSort(j, 1) = strTemp
End If
Next j
Next i
SortThisArray = aryToSort
End Function
And this is how you would use the function:
This is just a sample that you may adapt to your needs, it uses B11:B20 as NewRange:
Sub SortElseWhere()
Dim A As Range, NewRange As Range
Set A = Range("A1:A10")
Set NewRange = Range("B11:B20")
A.Copy NewRange
NewRange.Sort Key1:=NewRange(1, 1), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
The original cells are not sorted, they are merely copied to another location which is sorted.
EDIT#1:
In this version, NewRange is not a range of cells, but an internal array:
Sub SortElseWhere2()
Dim A As Range, NewRange(1 To 10) As Variant
Dim i As Long, strng As String
i = 1
Set A = Range("A1:A10")
For Each aa In A
NewRange(i) = aa
i = i + 1
Next aa
Call aSort(NewRange)
strng = Join(NewRange, " ")
MsgBox strng
End Sub
Public Sub aSort(ByRef InOut)
Dim i As Long, J As Long, Low As Long
Dim Hi As Long, Temp As Variant
Low = LBound(InOut)
Hi = UBound(InOut)
J = (Hi - Low + 1) \ 2
Do While J > 0
For i = Low To Hi - J
If InOut(i) > InOut(i + J) Then
Temp = InOut(i)
InOut(i) = InOut(i + J)
InOut(i + J) = Temp
End If
Next i
For i = Hi - J To Low Step -1
If InOut(i) > InOut(i + J) Then
Temp = InOut(i)
InOut(i) = InOut(i + J)
InOut(i + J) = Temp
End If
Next i
J = J \ 2
Loop
End Sub
Here I am submitting slightly different sort routine.It sorts the 2nd column first then 1st column.
Function BubbleSort(TempArray() As Variant, SortIndex As Long)
Dim blnNoSwaps As Boolean
Dim lngItem As Long
Dim vntTemp(1 To 2) As Variant
Dim lngCol As Long
Do
blnNoSwaps = True
For lngItem = LBound(TempArray) To UBound(TempArray) - 1
If TempArray(lngItem, SortIndex) > TempArray(lngItem + 1, SortIndex) Then
blnNoSwaps = False
For lngCol = 1 To 2
vntTemp(lngCol) = TempArray(lngItem, lngCol)
TempArray(lngItem, lngCol) = TempArray(lngItem + 1, lngCol)
TempArray(lngItem + 1, lngCol) = vntTemp(lngCol)
Next
End If
Next
Loop While Not blnNoSwaps
End Function
Sub Test()
Dim vntData() As Variant
vntData = range("C3:D9")
BubbleSort vntData, 2
BubbleSort vntData, 1
range("G3:H9") = vntData
End Sub
Results obtained from this routine are shown below.
How can I find a numeric number in the same cell after character. For ex After J* find number 01. I will have few rows and inside row some value will J*01 or J*08 im trying separate between character and number using instar in VBA:
Sub zz()
Dim ii As Long, z As Integer, xlastrow As Long
Dim yy As String
xlastrow = Worksheets("Sheet1").UsedRange.Rows.Count
For ii = 1 To xlastrow
yy = "J*"
z = 1
If IsNumeric(Worksheets("Sheet1").Range("B" & ii)) Then
This line separating number after J* character and pasting it to sheet2
Seprate.Find.Range("B" & ii, yy).Value = Worksheet("Sheet2").Range("A" & z)
End If
z = z + 1
Next ii
End Sub
Please try this code
' paste the values in column A.
q1w2e3r4asJ*66bvft654
1234BA
BA1234BA
xuz12354
''''' Code
Option Explicit
Sub Remove_Charecter()
Dim Last_Row As Double
Dim num As Double
Dim i As Integer
Dim j As Integer
Last_Row = Range("A65536").End(xlUp).Row
For i = 1 To Last_Row
num = 0
For j = 1 To Len(Cells(i, 1))
If IsNumeric(Mid(Cells(i, 1), j, 1)) Then
num = Trim(num & Mid(Cells(i, 1), j, 1))
End If
Next j
Cells(i, 2).Value = (num)
Next i
'MsgBox num
End Sub
'--- Output will be
123466654
1234
1234
12354
Try the below piece of codes.
Assumption
Your data that you need to separate is in Column A
There is no blank cells in your data
Trim value will be displayed in the adjacent column i.e. Column B in subsequent cells
Code :
Dim LRow As Double
Dim i As Integer
Dim j As Integer
Dim LPosition As Integer
Dim Number As Double
LRow = Range("A1").End(xlDown).Row
For i = 1 To LRow
Number = 0
LPosition = InStr(1, Cells(i, 1), "J*")
For j = (LPosition + 2) To Len(Cells(i, 1))
If IsNumeric(Mid(Cells(i, 1), j, 1)) Then
num = Trim(num & Mid(Cells(i, 1), j, 1))
End If
Next j
Cells(i, 2).Value = Number
Next i