sorting data by date with excel - vba

I have raw data I'm trying to sort out by date, the data is in this form:
month:april-2014
offer | value
ofr x | 2132
ofr y | 135
.
.
.
month:mai-2014
offer | value
ofr x | 5115
ofr z | 513
ofr y | 651
and it goes on, there are offers that apear every month and others that dissapear.
I wanted it to look like this :
offer | april-2014 |mai 14 | june ....
ofr x 123 5 6
ofr y 5 1 6
ofr z
ofr a
.
.
any help would be appreciated, thank you

Try to restructure the data like this and use pivot tables?
Date | offer | value
may-2014 |ofr x | 5115
may-2014 |ofr z | 513
may-2014 |ofr y | 651

This first chunk of code is going through and rearranging things for you. The other important thing it does is only sends one column from your selected range to the function. Some important things to remember are you may need to write the search criteria if you key word for "month" is not in the same spot in the text, the word offer is not by itself with no spaces in the following row. Another point of note, is this is treating everything as is. That means if the source cell was text, then the destination cell will be text. To convert from date as text to date as Excel serial that is a separate issue and there are plenty of ways to achieve that as well.
Option Explicit
Sub SortOffer(OfferList As Range)
Dim CounterX As Long, CounterY As Long, jCounter As Long, icounter As Long, MonthCount As Long, UniqueOffers As Long
Dim inlist As Boolean
Dim unsorted() As Variant
Dim sorted() As Variant
MonthCount = WorksheetFunction.CountIf(OfferList, "month*")
UniqueOffers = CountUnique(OfferList.Columns(1).Cells) - MonthCount - 1
ReDim sorted(1 To UniqueOffers + 1, 1 To MonthCount + 1) As Variant
unsorted = OfferList
CounterX = 1
jCounter = 1
sorted(1, 1) = "offer"
For CounterY = LBound(unsorted, 1) To UBound(unsorted, 1)
If Left(unsorted(CounterY, 1), 5) = "month" Then
CounterX = CounterX + 1
sorted(1, CounterX) = Right(unsorted(CounterY, 1), Len(unsorted(CounterY, 1)) - 6)
Else
inlist = False
For icounter = 2 To jCounter
If unsorted(CounterY, 1) = sorted(icounter, 1) Then
sorted(icounter, CounterX) = unsorted(CounterY, 2)
inlist = True
End If
Next icounter
If Not inlist And unsorted(CounterY, 1) <> "offer" And unsorted(CounterY, 1) <> "" Then
jCounter = jCounter + 1
sorted(jCounter, 1) = unsorted(CounterY, 1)
sorted(jCounter, CounterX) = unsorted(CounterY, 2)
End If
End If
Next CounterY
Range("F1").Resize(UBound(sorted, 1), UBound(sorted, 2)).Value = sorted
End Sub
This next function counts the number of unique entries in a range and does not count spaces. I stumbled across this code on this web page. If you subtract the number of months from this count, you will know how many offers are in your table. This is important because it will tell you how to size your array(alt link) that you will later write back as your results
Function CountUnique(ByVal MyRange As Range) As Integer
Dim Cell As Range
Dim J As Integer
Dim iNumCells As Integer
Dim iUVals As Integer
Dim sUCells() As String
iNumCells = MyRange.Count
ReDim sUCells(iNumCells) As String
iUVals = 0
For Each Cell In MyRange
If Cell.Text > "" Then
For J = 1 To iUVals
If sUCells(J) = Cell.Text Then
Exit For
End If
Next J
If J > iUVals Then
iUVals = iUVals + 1
sUCells(iUVals) = Cell.Text
End If
End If
Next Cell
CountUnique = iUVals
End Function
Now just in case the links don't cover it, this answer which was a learning lesson for me was taught in various parts to me by #JNevill, #Ralph, #findwindow, #Gary'sStudent and #ScottCraner. Appologies if I missed someone. I am also sure any of these individuals could do it slicker and take less then 10 hours to write it 8).

Related

Adding to every other array position MS Access

I'm needing to take one array (firstArray) and input into a second array (secondArray). However, the first four fields are the same value. After the first four positions, it begins to alternate in values.
Example:
firstArray
+---------+
| ID# |
| Name |
| month1 |
| month2 |
| month3 |
| etc... |
+---------+
secondArray
+----------+
| ID# |
| Name |
| month1 |
| month2 |
| NewField |
| month3 |
| NewField |
| month4 |
| etc... |
+----------+
I'm fairly new to VBA, so I apologize for the awful code.
Code so far:
Dim i As Integer
i = 0
Dim j As Integer
ReDim secondArray(0 To (fieldCount - 4) * 2)
Dim finalCountDown As Integer
finalCountDown = (fieldCount - 4) * 2
secondArray(0) = firstArray(0)
secondArray(1) = firstArray(1)
secondArray(2) = firstArray(2)
secondArray(3) = firstArray(3)
i = 3
j = 3
Do Until i > finalCountDown
i = i + 1
secondArray(i) = "NewField"
i = i + 1
j = j + 1
secondArray(i) = firstArray(j)
Loop
I also have a MsgBox to iterate through and output my fields:
'//------ testing output
i = 0
For i = 0 To finalCountDown
MsgBox secondArray(i)
Next i
I appreciate any help! If there's any confusion, I'll gladly try to explain some more!
EDIT:
The two arrays are of different size but are dynamic. firstArray is firstly set to 20 positions while secondArray is originally set to 32 positions. (These are calculated each time this process is ran with the archived data being pulled. This allows my users to add data and not have to worry about having to manually add in the values to my arrays.)
EDIT2:
I've added Erik's portion to my code with a few alterations. I also added a separate counter for my firstArray in order to make sure it's inputting the correct rows into the correct positions of my secondArray.
EDIT3:
Here is the code that ended up working for me:
Dim i As Integer
i = 0
Dim j As Integer
'removed the " - 4"
ReDim secondArray(0 To (fieldCount * 2))
Dim finalCountDown As Integer
'removed the " - 4"
finalCountDown = (fieldCount * 2)
secondArray(0) = firstArray(0)
secondArray(1) = firstArray(1)
secondArray(2) = firstArray(2)
secondArray(3) = firstArray(3)
i = 3
'created own counter for firstArray
j = 3
Do Until i > finalCountDown
i = i + 1
secondArray(i) = "NewField"
i = i + 1
j = j + 1
secondArray(i) = firstArray(j)
Loop
The error I was getting was due "Subscript not in Range" due to the fact that my finalCountDown variable was less than my array needed to be. Allowing the variable to become larger than my array allowed my array to finish iterating through itself and now inputs the proper fields in the proper order.
I'm accepting Erik's answer as it was the stepping stone to answering the question!
For the adjusted code, you can do a simple check to check if the j value is valid:
Dim i As Integer
i = 0
Dim j As Integer
ReDim secondArray(0 To (fieldCount - 4) * 2)
Dim finalCountDown As Integer
finalCountDown = (fieldCount - 4) * 2
secondArray(0) = firstArray(0)
secondArray(1) = firstArray(1)
secondArray(2) = firstArray(2)
secondArray(3) = firstArray(3)
i = 3
j = 3
Do Until i > finalCountDown
i = i + 1
finalArray(i) = "NewField"
i = i + 1
j = j + 1
If j => LBound(colheaders) And j <= UBound(colHeaders) Then
finalArray(i) = colHeaders(j)
End If
Loop

Excel VBA XIRR not working as expected

I am working a code, and I have a problem with Excel's XIRR function.
You have a matrix with 2 columns (dates and amounts), so the inputs are the matrix, a date, and a quantity. Inside the code it takes the values below the date you used as input, makes a new array with those values, and add also the date and amount you entered as inputs. And the output should be the XIRR of that array. It doesn´t seem to work. It works with IRR, with dates are an important input. Does someone know how to fix this problem? Thanks in advance!
Function Retorno(matriz As Range, dia As Date, valuacion As Double) As Double
Dim Datos As Range
Dim Aux1()
Dim Aux2()
Dim i, j, m, n As Integer
Set Datos = matriz
j = 0
For i = 1 To Datos.Rows.Count
If Datos(i, 1) <= dia Then
j = j + 1
End If
Next i
ReDim Aux1(1 To j + 1)
ReDim Aux2(1 To j + 1)
For n = 1 To j + 1
Aux1(n) = Datos(n, 2)
Next n
Aux1(j + 1) = valuacion
For m = 1 To j + 1
Aux2(m) = Datos(m, 1)
Next m
Aux2(j + 1) = dia
Retorno = WorksheetFunction.Xirr(Aux1, Aux2)
End Function
Your last Aux2(j + 1) = dia is overwriting the second date in the array with the first date, giving you two identical dates in the date array.
Possibly you want to delete that line.
The other possible answer to this problem is to convert the date to numbers if you do this: Aux2(m) = Datos(m, 1)*1 XIRR will work too.

Random Sampling & Selection by Category VBA

I am trying to write a macro on MS Excel, which will enable me to create random samples and pick random values from those samples for each category in the data.
To be more specific, the data is at 2 levels: firm and year, where each row represents a firm-year-peer observation. For each firm i, at a given year j, we have number of actual peers.
What I want to do is assign to each firm, from the whole sample throughout many years, a random firm from the list of all available firms at that specific year. The trick is that the number of firms to be assigned should be identical to the number of actual peers that a firm has at that year. Also, the randomly assigned values should be different from the firm's actual peers, and of course, the firm itself.
i j k
1 2006 100
1 2006 105
1 2006 110
2 2006 113
2 2006 155
2 2006 200
2 2006 300
For example, Firm 1's actual peers in year 2006 are 100, 105 and 110. However, all possible firms available are 100, 105, 110, 113, 155, 200 and 300. This means that I have to select 3 (because Firm 1 has 3 actual peers) random fictional peers from the 4 firms that are not Firm 1's peer that year (i.e. 113, 155, 200 and 300). Applying the same procedure for Firm 2, I need to select 4 random firms that are not Firm 2's actual peers from all possible firms.
I hope this was clear.
I started trying this function out on MS Excel, but I am open to suggestions if you think other platforms would be more useful.
Your help would be very much appreciated!
Thanks!
Many thanks to everyone who has visited my post.
After some initial struggling, I have managed to figure out the code myself. I am posting it below for anyone who might need it.
Basically I used the randomisation code posted by this gentle soul, and enhanced it for my needs using couple of flags for each new firm and each new year. Hope it is clear for everyone.
Best
Sub Random_Sampling()
'
Dim PeerCount, FirmCount, YearCount As Long
Dim Focal_CIK, fiscalYear As Long
Const nItemsTotal As Long = 1532
Dim rngList As Range
Dim FirmYearRange As Range
Dim FirmStart, FirmStartRow, YearStartRow As Long
Dim ExistingPeers As Range
Dim idx() As Long
Dim varRandomItems() As Variant
Dim i, j, k, m, n As Long
Dim iCntr, jCntr As Long
Dim booIndexIsUnique As Boolean
Set rngList = Sheets("Sheet2").Range("A2").Resize(nItemsTotal, 1)
FirmCount = Cells(2, 10).Value
For k = 1 To FirmCount
FirmStart = Application.WorksheetFunction.Match(k, Columns("E"), 0)
Focal_CIK = Cells(FirmStart, 1).Value
YearCount = Cells(FirmStart, 7).Value
For m = 1 To YearCount
Set FirmYearRange = Range("H" & FirmStart & ":H200000")
YearStartRow = Application.WorksheetFunction.Match(m, FirmYearRange, 0) + FirmStart - 1
fiscalYear = Cells(YearStartRow, 3).Value
PeerCount = Cells(YearStartRow, 9).Value
Set ExistingPeers = Range(Cells(YearStartRow + PeerCount, 2), Cells(YearStartRow + PeerCount, 2))
ReDim idx(1 To PeerCount)
ReDim varRandomItems(1 To PeerCount)
For i = 1 To PeerCount
Do
booIndexIsUnique = True ' Innoncent until proven guilty
idx(i) = Int(nItemsTotal * Rnd + 1)
For j = 1 To i - 1
If idx(i) = idx(j) Then 'Is already picked
ElseIf idx(i) = Focal_CIK Then 'Is the firm itself
booIndexIsUnique = False 'If true, don't pick it
Exit For
End If
For n = 1 To PeerCount
If idx(i) = Cells(YearStartRow + n - 1, 2).Value Then 'Is one of the actual peers
booIndexIsUnique = False 'If true, don't pick it
Exit For
Exit For
End If
Next n
Next j
If booIndexIsUnique = True Then
Exit Do
End If
Loop
varRandomItems(i) = rngList.Cells(idx(i), 1)
Rows(YearStartRow + PeerCount).EntireRow.Insert
'The order of the columns are very important for the following lines
Cells(YearStartRow + PeerCount, 1) = Focal_CIK
Cells(YearStartRow + PeerCount, 2) = varRandomItems(i)
Cells(YearStartRow + PeerCount, 3) = fiscalYear
Cells(YearStartRow + PeerCount, 4) = "0"
Next i
Next m
Next k
End Sub

WorksheetFunction.Match not working

Here is an excerpt from my data:
------+------+------+------+------+
| A | B | C | D |
------+------+------+------+------+
1 | 10 20 25 30
2 | 152 181 195 210
and my code:
Dim xrng as range, yrng as range, offset as integer
set xrng = Sheets("Sheet1").Range("A1:D1")
set yrng = Sheets("Sheet1").Range("A2:D2")
offset = WorksheetFunction.Match(23, xrng , 1) - 1
Why does running this result in a 1004 error: Unable to get the match property of the worksheetfunction class? How can I fix it?
EDIT: Detailed problem
Okay, I have written a function that does interpolation:
Public Function interpolate(intvalue_X As Double, xrange As range, yrange As range) As Double
....this is just an excerpt:
Dim offst As Integer
offst = WorksheetFunction.Match(intvalue_X, xrange, 1) - 1 'find the offset of the nearest value
---
End Function
With the following data and call, it works fine and returns the correct answer:
(don't mind the variables' who's declarations aren't shown - they have been declared at this point, it's just not copied)
Set intXrng = Sheets("Tables").range("B32:G32")
If beltWidth >= 46 And beltWidth <= 122 And conveyerCenter >= 7.6 And conveyerCenter <= 152.4 Then 'dan kan jy die tabel gebruik
m = interpolate(beltWidth, intXrng, Sheets("Tables").range("B44:G44"))
c = interpolate(beltWidth, intXrng, Sheets("Tables").range("B45:G45"))
powerX = m * conveyerCenter + c
Else
MsgBox "Unable to use the power x-factor table.", vbCritical
End If
Now, when I use the same function, but with this data and call, it gives the error:
Set intXrng = Sheets("Tables").range("F4:I4")
angleSurcharge = 23
capacityTable = interpolate(angleSurcharge, intXrng, Sheets("Tables").range("F7:I7"))
Your values are not stored as strings because they are in a table header. Table headers are always read as strings regardless of their format.
You can convert all values to the Doubles before passing it to Worksheet.Match to fix the bug.
Dim offst As Integer
Dim arry As Variant
ReDim arry(1 To 1, 1 To xrange.Columns.Count)
For i = 1 To xrange.Columns.Count
arry(1, i) = CDbl(xrange.Cells(1, i).Value)
Next
offst = WorksheetFunction.Match(intvalue_X, arry, 1) - 1 'find the offset of the nearest value

What could be slowing down my Excel VBA Macro?

This function goes through all integers and picks out binary values with only five ones and writes them to the spreadsheet.
To run this For x = 1 To 134217728 would take 2.5 days!!!! Help!
How could I speed this up?
Function D2B(ByVal n As Long) As String
n = Abs(n)
D2B = ""
Do While n > 0
If n = (n \ 2) * 2 Then
D2B = "0" & D2B
Else
D2B = "1" & D2B
n = n - 1
End If
n = n / 2
Loop
End Function
Sub mixtures()
Dim x As Long
Dim y As Integer
Dim fill As String
Dim mask As String
Dim RowOffset As Integer
Dim t As Date
t = Now
fill = ""
For x = 1 To 134217728
mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x))))
Debug.Print mask
If x > 100000 Then Exit For
If Len(mask) - Len(WorksheetFunction.Substitute(mask, "1", "")) = 5 Then _
RowOffset = RowOffset + 1
For y = 1 To Len(mask)
If Len(mask) - Len(WorksheetFunction.Substitute(mask, "1", "")) = 5 Then _
Range("mix").Offset(RowOffset).Cells(y) = Mid(mask, y, 1)
Next
Next
Debug.Print DateDiff("s", Now, t)
End Sub
By first sight guess, I think the problem lies in the fact that you do that cell by cell, which causes many read and write accesses.
You should do it range by range, like
vArr = Range("A1:C1000").Value
' it is array now, do something here effeciently
Range("A1:C1000").Value = vArr
You want find all 28bit numbers with 5 1s
There are 28*27*26*25*24/5/4/3/2=98280 such numbers
The following code took ~10 seconds on my PC:
lineno = 1
For b1 = 0 To 27
For b2 = b1 + 1 To 27
For b3 = b2 + 1 To 27
For b4 = b3 + 1 To 27
For b5 = b4 + 1 To 27
Cells(lineno, 1) = 2 ^ b1 + 2 ^ b2 + 2 ^ b3 + 2 ^ b4 + 2 ^ b5
lineno = lineno + 1
Next
Next
Next
Next
Next
mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x))))
The above line of code does the same thing (CStr(D2B(x))) twice.
Store the result of CStr(D2B(x)) in a variable & use that variable in the above line of code.
I've got 2 suggestions:
Get rid of the substitution command by counting the ones/zeroes in D2B and return an empty string if the count does not equal 5
Write these pre-filtered bitstrings to an array first and copy the array directly to the cells when finished.
Something like
ws.Range(ws.cells(1, 1), ws.cells(UBound(dstArr, 1) + 1, UBound(dstArr, 2) + 1)) = dstArr
The array-copy-trick greatly improves performance!