I am trying to compare two data series with dates and on a third column show ONLY the dates that are common in both data series (ordered in descending mode). A friend of mine helped me put together some code that seems to work but it seems to be taking a long time to generate the result when I have quite a long series of data. Is there a way to write this code differently that might get calculated faster? (I am currently using excel 2010.
The Function I enter on D2 and then I copy it down is: =next_duplicate(A2:$A$535,B2:$B$535,D1:$D$1)
Function next_duplicate(list1, list2, excluded)
For Each c In list1
If WorksheetFunction.CountIf(excluded, c) = 0 Then
If WorksheetFunction.CountIf(list2, c) > 0 Then
next_duplicate = c
Exit For
End If
End If
Next c
If next_duplicate = 0 Then
next_duplicate = "N/A"
End If
End Function
You can do this without VBA.
In Column C use COUNTIF to extract dates that appear only in both Columns A and B
=IF(COUNTIF($B$2:$B$7,"="&A2) > 0, A2, 0)
Then in Column D use an array formula (from here) to sort and remove blanks. Don't forget to select the range and then press control, shift and enter.
=INDEX(C2:C7, MATCH(LARGE(IF(ISBLANK(C2:C7), "", IF(ISNUMBER(C2:C7), COUNTIF(C2:C7, "<"&C2:C7), COUNTIF(C2:C7, "<"&C2:C7)+SUM(IF(ISNUMBER(C2:C7), 1, 0))+1)), ROW()-ROW($D$2)+1), IF(ISBLANK(C2:C7), "", IF(ISNUMBER(C2:C7), COUNTIF(C2:C7, "<"&C2:C7), COUNTIF(C2:C7, "<"&C2:C7)+SUM(IF(ISNUMBER(C2:C7), 1, 0))+1)), 0))
If #Dan's solution works, go with that since formula solutions are usually cooler :) If you need to use VBA, you can try this:
Sub Common()
Dim Date1 As Range
Dim Date2 As Range
Dim CommonDates() As Variant
Dim UniqueDates As New Collection
Set Date1 = Range("A2:A6")
Set Date2 = Range("B2:B6")
' Change the max array size to equal the length of Date1
' This is arbitrary and could be more efficient, for sure :)
ReDim CommonDates(Date1.Count)
' Set a counter that will increment with matches
i = 0
' Since a match needs to be in both, iterate through Date1 and check
' if the Match function returns a True value when checking Date2.
' If so, add that value to the CommonDates array and increment the counter.
For Each DateVal In Date1
If IsError(Application.Match(DateVal, Date2, 0)) = False Then
CommonDates(i) = DateVal.Value
i = i + 1
End If
Next
' Filter out dupes (in case that is possible - if not, this can be removed
' and the bottom part reworked
On Error Resume Next
For Each Value In CommonDates
UniqueDates.Add Value, CStr(Value)
Next Value
' Now go to the first cell in your Common Dates range (I'm using C2) and
' print out all of the results
Range("C2").Activate
For j = 1 To UniqueDates.Count
ActiveCell.Value = UniqueDates(j)
ActiveCell.Offset(1).Activate
Next j
' Back to the beginning
Range("C2").Activate
' Use this if you don't need to filter dupes
'For Each r In CommonDates
' ActiveCell.Value = r
' ActiveCell.Offset(1).Activate
'Next
End Sub
It basically iterates over Date1 and checks if the Match formula succeeds/fails in Date2. A success = match, which means a common date. Those are then printed to another column. Hope this helps!
Related
I have an excel file that contains data exported from LTSpice simulations. There are 280 different runs however the data is exported as two columns (time and voltage) with a run cell at the start of a new run. The number of data points in each run varies. Looks something like this:
Run 1/280
Time1 Voltage1
Time2 Voltage2
Run 2/280
Time1 Voltage1
Time2 Voltage2
Time3 Voltage3
Run 3/280
I would like to have the run cells as row and the time and voltage columns beneath them.
Run 1/280 Run 2/280 Run 3/280
Time1 Voltage1 Time1 Voltage1
Time2 Voltage2 Time2 Voltage2
Time3 Voltage3
I haven't found an easy way to do this yet, so any help would be appreciated.
Thanks
Without VBA...
For each row of your input list, you need to identify its type (Run x/xxx header or terminal, voltage pair) and the row and pair of columns in the output where this input row belongs.
In the picture below, columns A and B perform this task. Column A identifies the output column pair and B the output row, where row 0 indicates the header row of the output.
The header row of the output utilises the fact that if an array is sorted in ascending order and has repeated values then MATCH(x,array,0) finds the index of the first element in array equal to x. The cumbersome repetition of the SUMPRODUCT term in the formulae for the other rows is necesssary for the following reason. If there is no matching pair in columns A and B to the current output row and column pair number then the SUMPRODUCT delivers 0 and, unfortunately, the INDEX(array,SUMPRODUCT()) term evaluates to INDEX(array,0) which delivers the first element of array (*) - which is not what is wanted.
You obviously need sufficient helper values in row 1 and column E of the worksheet in the output area - the maximum values of columns B and A, respectively determine the requirements. Oversizing the output (as the picture has done) is not a problem as the formulae in any redundant positions simply evaluate to "".
(*) In fact, for a single column array the formula =INDEX(array,0) evaluates to the array itself. When used as cell formula (rather than being used as an array formula across a range of cells) formula simply picks the first value from array.
Please try this code.
Sub SplitToColumns()
' 16 Sep 2017
Dim WsS As Worksheet ' S = "Source"
Dim WsD As Worksheet ' D = "Destination"
Dim WsDName As String
Dim RunId As String ' first word in "Run 1/280"
Dim RowId As Variant ' value in WsS.Column(A)
Dim Rl As Long ' last row (WsS)
Dim Rs As Long, Rd As Long ' row numbers
Dim Cd As Long ' column (WsD)
WsDName = "RemoteMan" ' change to a valid tab name
Application.ScreenUpdating = False
On Error Resume Next
Set WsD = Worksheets(WsDName)
If Err Then
' create WsD if it doesn't exist:
Set WsD = Worksheets.Add(After:=Worksheets(Worksheets.Count))
WsD.Name = WsDName
Cd = -1
Else
' continue adding new data to the right of existing,
With WsD.UsedRange
Cd = .Columns.Count - 1
If Cd = 1 And .Rows.Count = 1 Then Cd = -1
End With
End If
Set WsS = Worksheets("Remote") ' change to a valid tab name
With WsS
' presume "Run" & Time in column A, Voltage in Column B
' presume: no blank rows
Rl = .Cells(Rows.Count, "A").End(xlUp).Row
RunId = .Cells(2, 1).Value ' row 2 must have the RunId
RunId = Left(RunId, InStr(RunId, " ") - 1)
For Rs = 2 To Rl ' assume data start in row 2 (A1 may not be blank!)
RowId = .Cells(Rs, "A").Value
If InStr(1, RowId, RunId, vbTextCompare) = 1 Then
Rd = 1 ' first row to use in WsD
Cd = Cd + 2 ' determine next columns
End If
WsD.Cells(Rd, Cd).Value = RowId
WsD.Cells(Rd, Cd + 1).Value = .Cells(Rs, "B").Value
Rd = Rd + 1 ' next row to use
Next Rs
End With
Application.ScreenUpdating = True
End Sub
I am working on algorithm base tool; Kindly assist me for below problem.
1.First I find row number based on one criteria (Dynamic). Assume row number is 5 and it has set of Value From (B5:F5)
Set FindRow = SearchRange.Find(Sheet1.Cells(xRow, 2).Text, LookIn:=xlValues, lookat:=xlWhole)
MyRow = FindRow.Row
2.I have header with numeric value(B1:F1)
3.Then I need to find column number, ie MyCol is column number of minimum value cell in (B1:F1)
4.Then I test one criteria with If Cells(MyRow,MyCol)="ABC" Then test fail and again I need go and find next Minimum value in (B1:F1) and column number, ie MyCol, Until I Meet the condition.
I tried array, I am not able to find solution, Any help would be much appreciated. My Thanks in advance.
If I understand correctly, what you need is an indexed sort. Many languages provide an indexed sort as a standard function. VBA has neither a sort nor an indexed sort as standard.
With a conventional array sort, values are sorted within the array. For example: suppose I have an array with values:
A D B E C
If I pass that array to a sort, it is returned as:
A B C D E
But sometimes you cannot sort the array. In your case, the array is a range of column headings. You cannot sort those headings because they belong with their columns. You would have to sort the columns which is at best impractical and probably unacceptable since the sequence of columns will mean something.
With an indexed sort, you create arrays Keys and Indices:
Keys A D B E C
Indices 1 2 3 4 5
Both these arrays are passed to the sort which leaves Keys unchanged and sorts Indices to give:
Indices 1 3 5 2 4
With the regular sort, you access the sorted entries as Array(1). Array(2) and so on. With an indexed sort, you access the sorted entries as Array(Indices(1)). Array(Indices(2)) and so on.
Going via an index to get the sorted entries can be a little difficult to understand at first and it is undoubtedly fiddlier that going directly to the source array.
Below I have given you an indexed Insertion Sort. An Insertion Sort is simple and easy to understand but is slow with large numbers of entries. You only have five entries to sort so its performance is acceptable. Look at the Wiki entry for "Insertion Sort" for a pictorial demonstration of how it works.
Macro DemoSortColumnHeadings shows how to use the sort and how to access the column headings. I have used the name ColHeads instead of Keys and ColNums instead of Indices because I believe this will make DemoSortColumnHeadings easier to understand. The sorted ColNums contains the column numbers in the sequence you require. After the sort, the array ColHeads is no longer required.
One last point. VBA is the only language I know which allows you to specify both the lower bound and the upper bound of an array. Most languages require the lower bound to be zero. I have taken advantage of this to define the dimensions of the arrays as (2 to 6) and not (0 to 4). This is why the values in array ColNums are column numbers. With most languages, I would have needed ColNums(N)+2 to get the column number.
Option Explicit
Sub DemoSortColumnHeadings()
Const ColFirst As Long = 2 ' Column B = column 2
Const ColLast As Long = 6 ' Column F = column 6
Dim ColCrnt As Long
Dim ColNums() As Long
Dim InxColNum As Long
Dim ColHeads() As String
With Worksheets("Test data")
ReDim ColHeads(ColFirst To ColLast)
ReDim ColNums(ColFirst To ColLast)
For ColCrnt = ColFirst To ColLast
ColHeads(ColCrnt) = .Cells(1, ColCrnt).Value
ColNums(ColCrnt) = ColCrnt
Next
Debug.Print "Initial sequence"
Debug.Print "|";
For ColCrnt = ColFirst To ColLast
Debug.Print .Cells(1, ColCrnt).Value & "|";
Next
Debug.Print
Call InsertionSort(ColNums, ColHeads)
Debug.Print "Final sequence"
Debug.Print "|";
For InxColNum = LBound(ColNums) To UBound(ColNums)
ColCrnt = ColNums(InxColNum)
Debug.Print .Cells(1, ColCrnt).Value & "|";
Next
Debug.Print
End With
End Sub
Public Sub InsertionSort(ByRef Indices() As Long, ByRef Keys() As String)
Dim Found As Boolean
Dim I As Long
Dim InxIFwd As Long
Dim InxIBack As Long
For InxIFwd = LBound(Indices) + 1 To UBound(Indices)
I = Indices(InxIFwd) ' Save value of current entry in Indices
' Find first entry back, if any, such that Keys(I) >= Keys(Indices(InxIBack))
' If Keys(I) < Keys(Indices(InxIBack)), set Indices(InxIBack+1) to
' Indices(InxIBack). That is move indices for keys greater that Keys(I) down
' Indices leaving a space for I nearer the beginning.
Found = False
For InxIBack = InxIFwd - 1 To LBound(Indices) Step -1
If Keys(I) >= Keys(Indices(InxIBack)) Then
' Keys(I) belongs after Keys(Indices(InxIBack))
Indices(InxIBack + 1) = I
Found = True
Exit For
End If
Indices(InxIBack + 1) = Indices(InxIBack)
Next
If Not Found Then
' Insertion point for I not found so it belongs at beginning of Indices
Indices(LBound(Indices)) = I
End If
Next
End Sub
I'm developing a VBA function for Excel. It will take input parameters of an integer (we'll call it ref_num), and a range. It will search through the range, looking for ref_num as the value of a cell. When it finds ref_num (which may or may not be present), it will go to the second row of the column that ref_num is in, and store that value as a string in the return variable (the value is a date, and 1-31 each have their own column). Every time ref_num is found in a column, the value in the second row will be appended to the return string.
Slightly more concrete example:
ref_num is 2, and 2 occurs in columns A, B, and C. The values in A2, B2, and C2 are 1, 2, and 3, respectively, so the function must return "1, 2, 3".
This is my pseudo-code, but I need some help filling in the blanks...
Note that this currently does not work, and that the algorithm is very much brute force. I just want to get something working.
Function GetDays(ref_num As Integer, range_o_cells As Range) As String
Dim num_dates As Integer
Dim day As String
Set num_dates = 0
'iterate through all the cells and see if the value is ref_num
For Each c In range_o_cells
If c.Value = ref_num Then
'get the cell's column, then reference the second row and get the value. Note that this will be an int that we need to convert to a string
'I seriously doubt the following line will work
day = CStr(Cells(c.Column, 2).Value)
'Once you have the value, append it to the return value
If num_dates = 0 Then
'This is the first value we've found, so we don't need to prepend a comma
GetDays = day
num_dates = 1
Else
'This is probably not valid VBA syntax...
GetDays = GetDays & ", " & day
End If
Next c
End Function
Note that currently, if I call it like this: =GetDays(AG39, $P$3:$W$500) where AG39 is the cell containing ref_num, I get #NUM!
There are multiple issues in your code
You don't use Set for integers
Missing an End If
As you suspected, your indexing into Cells is iffy
You should build your return string into day and assign it to the function in one place
Looping over a range is Slow
You should declare all variables
Better approach is to move the data to a variant array, and loop that. Also include the header data in the range passed to range_o_cells (I'm guessing thats $P$1:$W$500)
Here's your code refactored
Function GetDays( _
ref_num As Long, _
range_o_cells As Range, _
Optional Sep As String = ", ") As String
Dim dat As Variant
Dim rw As Long, col As Long
Dim day As String
dat = range_o_cells.Value
For col = 1 To UBound(dat, 2)
For rw = 3 To UBound(dat, 1)
If dat(rw, col) = ref_num Then
day = day & dat(2, col) & Sep
End If
Next rw, col
If Len(day) > 0 Then day = Left$(day, Len(day) - Len(Sep))
GetDays = day
End Function
I would like to ask your help to resolve an issue I'm facing building an algorithm.
Available data
We have a table of data with 10 rows and 30 columns.
Each row corresponds to the variable linkied to a specific parameter (for example weight of Apples, weight of Pears,weight of Oranges... Paramter10)
Each column corresponds to the value the variable can take.
This how we have 30 possible values for each variable/parameter.
Goal of the algorithm
Give the sum of all possible combinations of these parameters (Apples+Pears+ Oranges+...+Paramter10), normally there should be 30^10 possible combinations
Description of my version of the algorithm
It is to create an array of 10, let's say, indexes. Each index is corresponding to the variable/parameter. Each index is filled by one out of 30 possible values.
Create a loop passing through the columns in the same row. Each value of the cell in the table is placed in the corresponding index (row 1, for index 1)
Each change corresponds to the next available value (on the right) in the same row but with a different column. While the column is terminated, the algorithm starts to do the same for the next row.
Every change in the array varlues has to give as result a new sum, copied in a new cell somewhere in the table.
Sub AlgoSum()
Dim rw As Long, column1 As Long
Dim Sum1(9) As Long 'The array with 10 index 'First difficulty is to find a way how to synchornize the sum with every change in array Sum1.
Do While i <= 8 'My version is to place it in first but not sure it is right
For rw = 1 To 9
For column1 = 1 To 30
If Not IsEmpty(Worksheets("Sheet1").Cells(rw, column1)) Then 'verify that the cell is not empty
Sum1(i) = Worksheets("Sheet1").Cells(rw, column1).Value
Worksheets("Sheet1").Cells(rw+30, column1+30).Value = Application.WorksheetFunction.Sum(Sum1)
Else 'normally if it is empty it should move to the next value but I didn't find the appropriate way to do it, this why I thought about this compromise
Sum1(i) = 0
Worksheets("Sheet1").Cells(rw+30, column1+30).Value = Application.WorksheetFunction.Sum(Sum1)
End If
Next column1
Next rw
i = i + 1
Loop
End Sub
This code is not giving the appropriate results. It's not giving the sum for every change in the array, and it's not making the change in the array in the way it has to.
I've seen possible solution with a recursive, but didn't find the right way to do it.
Some help is very welcome!
Thank you in advance!
Try this. It's recursive (although it does use a loop as well).
Use the constants at the top to adjust to your data.
Try it with a few rows and a few columns.
The current constants assume that your data starts in cell A1, and that there are 3 "variables" and 2 "values".
It will print the results to the immediate window as it goes, but you could certainly adjust it to store in an array or print to another sheet.
' number of "variables"
Const ROWS As Integer = 3
' number of "values"
Const COLS As Integer = 2
' upper left cell of table
Const CELL_UPPER_LEFT As String = "A1"
' Recursive method to sum the values of all the combinations of all the rows.
' Method will print the result in the immediate window for now.
' #param row_number Integer Number of rows of data
' #param sum Double Running sum of previous rows
Private Sub recursiveSum(ByVal row_number As Integer, ByVal sum As Double)
' if we've reached the bottom, then print the result and go back up
If row_number = ROWS Then
Debug.Print sum
Exit Sub
End If
' loop over the number of columns
Dim col_number As Integer
For col_number = 0 To COLS - 1
' make a recursive call, increasing the sum by the current row and increasing the row number by 1
recursiveSum row_number + 1, Range(CELL_UPPER_LEFT).Offset(row_number, col_number).Value + sum
' when we return from the recursive call we will be here - ready to start the next time through the loop
Next
End Sub
' Wrapper function for the recursive method.
Public Sub recursiveSumWrapper()
' make the initial recursive call
recursiveSum 0, 0
End Sub
Thank you really for your reply. Your solution is working perfectly with debug.print!
I was able to add an automatic dimensioning of the table:
' number of "variables"
Dim ROWS As Integer
' number of "values"
Dim COLS As Integer
' upper left cell of table
Const CELL_UPPER_LEFT As String = "A1"
ROWS = Worksheets("Sheet1").UsedRange.ROWS.Count
COLS = Worksheets("Sheet1").UsedRange.Columns.Count
a = (ROWS) ^ (COLS) 'The number of possible combinations
However I spent all the morning to change debug.print for another option:
If row_number = ROWS Then
Debug.Print sum
Exit Sub
End If
For a more convenient possibility for the following use of obtained data
If row_number = ROWS Then
For i = 1 To a
Worksheets("Sheet2").Cells(20, a).Value = sum
Exit Sub
Next
End If
As I understand, it's not the right place to use a loop, because I get the error: «Subscript out of range». My intuition is telling me it's ROWS which doesn't correspond to a.
Do you have any idea about this detail? Is it possible to use debug.print information directly?
I have a long excel list (+10k rows) and a column with ordernumbers.
Unfortunatelly some orders were deleted.
My question is simple but to achieve probabily not: I want to count the deleted rows, basically the missing ordernumbers.
A hint is aprechiated.
endo
I don't know how to do this using Excel code, but if you go to the bottom and get the last order number, you can calculate how many there should be with
last order number - first order number = expected amount
How many their actually are would be
last order index - first order index = actual amount
Then you can do
expected amount - actual amount = missing order numbers
Of course, this assumes there are no blank rows between order numbers, and that you only need to do this once. (you prob want a function or something to have it update as you change the spreadsheet)
This covers blank rows and numbers missing from the sequence (however, if your min/max are deleted, this can't detect that). It's similar to #shieldgenerator7's answer.
No sorting necessary for this.
EDIT: As sheildgenerator7 pointed out, this assumes that you expect all of your order numbers to be sequential.
=(MAX(A2:A26)-MIN(A2:A26)+1)-COUNTA(A2:A26)
You can now count blanks in Excel with a simple function called COUNTBLANK. If you know the ending row number (for example, if the data were in A1 to A10000), you can use this formula:
=COUNTBLANK(A1:A10000)
If the numbers are sequential it is pretty easy.
Sort by order number
Count in B4
=(A4-A3)-1
Sum in B17
=SUM(B3:B16)
Here's something I put together to identify missing numbers and optionally print the list out on a new workbook.
You can change the minimum and maximum number, and it does not matter if the list is sorted or not.
Sub FindMissingNumbers()
Dim lstRange As Range
Dim r As Long
Dim lowestNumber As Long
Dim highestNumber As Long
Dim missingNumbers() As Variant
Dim m As Long
Dim wbNew As Workbook
'## Set this value to the lowest expected value in ordernumber'
lowestNumber = 0
'## Set this value to your highest expected value in ordernumber'
highestNumber = 100
'Assuming the order# are in column A, modify as needed:'
Set lstRange = Range("A1", Range("A1048576").End(xlUp))
For r = lowestNumber To highestNumber
'## Check to see if this number exists in the lstRange
If IsError(Application.Match(r, lstRange, False)) Then
'## Add this number to an array variable:'
ReDim Preserve missingNumbers(m)
missingNumbers(m) = r
m = m + 1
End If
Next
If MsgBox("There were " & m & " missing order numbers" _
& vbNewLine & "Do you want to print these numbers?", vbYesNo) = vbYes Then
Set wbNew = Workbooks.Add
With wbNew.Sheets(1)
' For r = LBound(missingNumbers) To UBound(missingNumbers)
' .Range("A1").Offset(r, 0).Value = missingNumbers(r)
' Next
.Range("A1").Resize(UBound(missingNumbers) + 1) = _
Application.WorksheetFunction.Transpose(missingNumbers)
End With
Else:
End If
End Sub