I have two rows of cells: A1, B1, C1 and A2, B2, C2. In each of these 2 rows there can only be a single 1, with the two other cells set as 0. Here is one example occurrence:
A B C
+---+---+---+
1 | 1 | 0 | 0 |
+---+---+---+
2 | 0 | 1 | 0 |
+---+---+---+
I'm trying to iterate over all 9 possible combinations: 3 possibilities for the first row times 3 possibilities for the second. How would I go about doing this?
Here is one way:
Function delta(i As Long, n As Long) As Variant
'returns an array of length n
'consisting of all 0 with one 1
'at index i
Dim A As Variant
ReDim A(1 To n) As Long
A(i) = 1
delta = A
End Function
Sub IterateOver()
Dim i As Long, j As Long
For i = 1 To 3
Range("A1:C1").Value = delta(i, 3)
For j = 1 To 3
Range("A2:C2").Value = delta(j, 3)
'stub for real code:
MsgBox "Continue?", vbQuestion, "Test"
Next j
Next i
End Sub
This will generate all 8 combinations of 0 and 1 for 3 columns
Dim i As Integer
For i = 1 To 2^3
Range("A" & i) = (i-1) % 2
Range("B" & i) = Int((Range("A" & i))/2) % 2
Range("C" & i) = Int((Range("B" & i))/2) % 2
Next i
Try to extend it yourself
Related
I have to produce a list of combinations which are indicators to fields as I am trying to produce some conditions to interrogate data.I have some code for the combinations from here.
In the example of Power/Torque/Cylinders with a combination of 1,2,4:
I need to work out the combinations of those 3 fields, so the output would be:
So essentially all combinations but not from the same 'bucket' if that makes sense?
Edit:
The number of combinations (ie 3 in the example) will change as per the link I provided. The combinations from the link determine which field to look at or use. Eg combination 123 would be the first 3 fields in the image. Combination 1,2 would be tge first 2 and 1,3 would be first and last. I have the code for that.
Now we have the combination buckets, need to work through the combinations across thise fields.
Also I am looking for guidance on how to approach the algo and not necessarily someone to do it for me 😊
As another example, if 1,2,3 were the column combination, the expected output would be:
20-0.5-200
20-0.5-300
20-0.5-400
etc
Nested Loop:
Sub allCombo(set1 As Range, set2 As Range, set3 As Range)
Dim c1, c2, c3, n
For Each c1 In set1
For Each c2 In set2
For Each c3 In set3
n = n + 1
Debug.Print "#" & n, c1, c2, c3
Next c3
Next c2
Next c1
End Sub
Example Usage:
Sub test()
allCombo [I2:I4], [J2:J3], [L2:L3]
End Sub
Result:
#1 20 0.5 4
#2 20 0.5 8
#3 20 0.8 4
#4 20 0.8 8
#5 30 0.5 4
#6 30 0.5 8
#7 30 0.8 4
#8 30 0.8 8
#9 40 0.5 4
#10 40 0.5 8
#11 40 0.8 4
#12 40 0.8 8
Here is an option that is completely dynamic:
Option Explicit
Sub MakeCombos()
Dim myCols As Variant, i As Long, j As Long, myCombos() As Variant
Dim temp() As Variant, LastRow As Long, lngCol As Long, myLens() As Long
Dim index() As Long, totalCombs As Long, count As Long
'' Prompt user for columns N.B. there is no
'' data validation, so enter with caution
myCols = Split(InputBox("Enter the columns as a comma separated list: ", "Column Combos 3000"), ",")
ReDim myCombos(0 To UBound(myCols))
ReDim index(0 To UBound(myCols))
ReDim myLens(0 To UBound(myCols))
totalCombs = 1
'' This loop is simply populating myCombos
'' with the chosen columns. We are also populating
'' myLens with the maximum length of each column
For i = 0 To UBound(myCols)
lngCol = CLng(myCols(i))
With ActiveSheet
LastRow = .Cells(.Rows.count, lngCol).End(xlUp).Row
End With
ReDim temp(0 To LastRow - 2)
For j = 2 To LastRow
temp(j - 2) = Cells(j, lngCol)
Next j
myCombos(i) = temp
myLens(i) = LastRow - 2
'' Get the total number of combinations
totalCombs = totalCombs * (LastRow - 1)
Next i
'' This is where the magic happens. Note, we
'' don't have nested for loops. Rather, we are keeping
'' up with the correct index with the appropriately
'' named array "index". When one of the indices exceeds
'' the maximum length, we reset that index and increment
'' the next index until we have enumerated every combo
While (count < totalCombs)
For j = 0 To UBound(myCols)
Cells(count + 20, j + 1) = myCombos(j)(index(j))
Next j
j = UBound(index)
index(j) = index(j) + 1
Do While index(j) > myLens(j)
index(j) = 0
j = j - 1
If j < 0 Then Exit Do
index(j) = index(j) + 1
Loop
count = count + 1
Wend
End Sub
Here is the example input:
And here is the top of the output for entering 1,2,4 at the prompt:
And here is the top of the output for entering 2,3 at the prompt:
Here is a sub that first determines the number of items in columns I, J, L and adjust the loops accordingly:
Sub SteveP()
Dim N1 As Long, N2 As Long, N3 As Long, K As Long
Dim m1 As Long, m2 As Long, m3 As Long
Dim a As Variant, b As Variant, c As Variant
N1 = Cells(Rows.Count, "I").End(xlUp).Row
N2 = Cells(Rows.Count, "J").End(xlUp).Row
N3 = Cells(Rows.Count, "L").End(xlUp).Row
K = 1
For m1 = 2 To N1
a = Cells(m1, "I")
For m2 = 2 To N2
b = Cells(m2, "J")
For m3 = 2 To N3
c = Cells(m3, "L")
Cells(K, "M") = a
Cells(K, "N") = b
Cells(K, "O") = c
K = K + 1
Next m3
Next m2
Next m1
End Sub
so i have an excel file with multiple columns and rows. At the moment it looks like this:
| A | B | C | D
---------------------
1 | 1a | 1b | 1c | 1d
---------------------
2 | 2a | 2b | 2c | 2d
---------------------
3 | 3a | 3b | 3c | 3d
----------------------
How can i randomise it with VBA so that it becomes:
| A | B | C | D
---------------------
1 | 3a | 3b | 3c | 3d
---------------------
2 | 1a | 1b | 1c | 1d
---------------------
3 | 2a | 2b | 2c | 2d
----------------------
It's true that this question has many possible answers. This is probably the most lame one, but it works quite ok actually:
Add an additional column;
Then put random value in this column;
Sort by this column - that's exactly what you want!
Delete the additional column, so the trick is no visible!
Voila!
Just to give you some idea how this should look like:
Option Explicit
Public Sub Randomize()
Dim lCounter As Long
Application.ScreenUpdating = False
Columns("A:A").Insert Shift:=xlToRight
For lCounter = 1 To 5
Cells(lCounter, 1) = Rnd()
Next lCounter
With ActiveSheet.Sort
.SortFields.Add Key:=Range("A1:A5")
.SetRange Range("A1:E5")
.Apply
End With
Columns("A:A").Delete
Application.ScreenUpdating = False
End Sub
It would work on data like this one:
You can further update the code, by removing the magic numbers and improving the ranges.
I'd go like follows:
Sub ShuffleRows()
Dim vals As Variant, val As Variant
Dim iRow As Long
With Range("A1").CurrentRegion '<--| reference your contiguous range
vals = .Value '<--| store its content in an array
For Each val In GetRandomNumbers(.Rows.count) '<--| loop through referenced range shuffled rows indexes
iRow = iRow + 1 '<--| update current row to write in counter
.Rows(iRow).Value = Application.Index(vals, val, 0) '<--| write in current rows to write the random row from corresponding shuffled rows indexes
Next
End With
End Sub
Function GetRandomNumbers(ByVal n As Long) As Variant
Dim i As Long, rndN As Long, tempN As Long
ReDim randomNumbers(1 To n) As Long '<--| resize the array to the number of rows
For i = 1 To n '<--| fill it with integer numbers from 1 to nr of rows
randomNumbers(i) = i
Next
'shuffle array
Do While i > 2
i = i - 1
Randomize
rndN = Int(i * Rnd + 1)
tempN = randomNumbers(i)
randomNumbers(i) = randomNumbers(rndN)
randomNumbers(rndN) = tempN
Loop
GetRandomNumbers = randomNumbers
End Function
This is my solution:
First I have created a function to generate random numbers between a and b without repeated values:
jlqmoreno#gmail.com
Julio Jesus Luna Moreno
Option Base 1
Public Function u(a As Variant, b As Variant) As Variant
Application.Volatile
Dim k%, p As Double, flag As Boolean, x() As Variant
k = 1
flag = False
ReDim x(1)
x(1) = Application.RandBetween(a, b)
Do Until k = b - a + 1
Do While flag = False
Randomize
p = Application.RandBetween(a, b)
'Debug.Assert p = 2
resultado = Application.Match(p, x, False)
If IsError(resultado) Then
k = k + 1
ReDim Preserve x(k)
x(k) = p
flag = True
Else
flag = False
End If
Loop
flag = False
Loop
u = x
End Function
this is nessesary since i needed a funtion to create random indices with no duplicates (This was the rough part)
Then i used this function using the logic i applied here
with this function:
Public Function RNDORDER(rango As Range) As Variant
Dim z() As Variant, n%, m%, i%, j%, y() As Variant, k%
n = rango.Rows.count
m = rango.Columns.count
k = 1
ReDim x(n, m)
ReDim y(n)
y = u(1, n)
For i = 1 To n
For j = 1 To m
x(i, j) = rango(y(i), j)
Next j
Next i
RNDORDER = x
Just run this function as an array function.
Thanks!
I have this sub in Excel 2010 that transfers columns from other sheets and inserts it into a table. The new table has 7 columns. The first 5 are just copying right from the other sheets and they work fine. The last two, however, are supposed match the Program Number from the new table against the Program Number in one of two other sheets and copy the column from there. These are the two that don’t work. It doesn’t throw any errors, the columns just don’t populate.
This is the excerpt that isn’t working. I’m quite new to VBA in excel so any assistance would be greatly appreciated.
Sub Program_List()
Dim SiteNoTransfer As String
Dim SiteNo As String
Dim TransferCol(7) As Integer
Dim Row As Integer
Dim RowTransfer As Integer
Dim StartColumn As Integer
Dim rSrc As Range
Dim rDst As Range
TransferCol(0) = 0 'Nothing (placeholder)
TransferCol(1) = 10 'Proj No, from Data
TransferCol(2) = 1
TransferCol(3) = 3
TransferCol(4) = 11
TransferCol(5) = 15
TransferCol(6) = 10 'From Sheet 1 or 2
TransferCol(7) = 17 'From Sheet 1 or 2
StartColumn = 45
Row = 7
Do While True
SiteNo = Worksheets("RESULTS").Cells(Row, StartColumn - 11)
If SiteNo = "" Then
Exit Do
ElseIf Not SiteNo = "" Then
RowTransfer = 4
Do While True
SiteNoTransfer = Worksheets("Data").Cells(RowTransfer, TransferCol(1))
If SiteNoTransfer = "END" Then
Exit Do
ElseIf SiteNoTransfer = SiteNo Then
Worksheets("RESULTS").Cells(Row, StartColumn + 1).Interior.Color = RGB(0, 255, 255)
Worksheets("Data").Cells(RowTransfer, TransferCol(1)).Interior.Color = RGB(0, 100, 255)
For i = 1 To 4
If Not TransferCol(i) = 0 Then
Worksheets("RESULTS").Cells(Row, StartColumn + i) = Worksheets("Program").Cells(RowTransfer, TransferCol(i))
End If
Next
For i = 5 To 5
If Not TransferCol(5) = 0 Then
Set rSrc = Sheets("Data").Cells(RowTransfer, TransferCol(5))
Set rDst = Sheets("RESULTS").Cells(Row, StartColumn + i)
rDst = rSrc
rDst.NumberFormat = "yyyy"
Exit Do
End If
Next
'Where the code stops
For i = 6 To 6
If Not TransferCol(6) = 0 Then
If Worksheets("RESULTS").Cells(Row, StartColumn + 1) = Worksheets("Sheet1").Cells(Row, TransferCol(1)) Then
Worksheets("RESULTS").Cells(Row, StartColumn + i) = Worksheets("Sheet1").Cells(RowTransfer, TransferCol(6))
End If
ElseIf Worksheets("RESULTS").Cells(Row, StartColumn + 1) = Worksheets("Sheet 2").Cells(Row, TransferCol(1)) Then
Worksheets("RESULTS").Cells(Row, StartColumn + i) = Worksheets("Sheet 2").Cells(RowTransfer, TransferCol(6))
End If
Next
For i = 7 To 7
If Not TransferCol(7) = 0 Then
If Worksheets("RESULTS").Cells(Row, StartColumn + 1) = Worksheets("Sheet 1").Cells(Row, TransferCol(1)) Then
Worksheets("RESULTS").Cells(Row, StartColumn + i) = Worksheets("Sheet 1").Cells(RowTransfer, TransferCol(7))
End If
ElseIf Worksheets("RESULTS").Cells(Row, StartColumn + 1) = Worksheets("Sheet 2").Cells(Row, TransferCol(1)) Then
Worksheets("RESULTS").Cells(Row, StartColumn + i) = Worksheets("Sheet 2").Cells(RowTransfer, TransferCol(7))
End If
Next
End If
RowTransfer = RowTransfer + 1
Loop
End If
Row = Row + 1
Loop
End Sub
EDIT: This is about what the sheets look like.
Sheet 1
| Project No. | Col 2 |... | Col 6 | Col 7
+------------+---------+-------+---------+
| 12-3456 | Date|... | 1234| 0987
+------------+---------+-------+---------+
| 22-3456 |Date|...| 2234 | 9876
+------------+---------+-------+---------+
Sheet 2
| Project No. | Col 2 |... | Col 6| Col 7
+------------+---------+-------+---------+-------------
| 32-3456 | Date |... | 3234 | 8765
+------------+---------+-------+---------+------------+
Results
| Project No. | Col 2 |... | Col 6 | Col 7
+------------+---------+-------+---------+-------------
| 12-3456 | Date |... | 1234 | 0987
+------------+---------+-------+---------+------------+
| 22-3456 | Date |... | 2324 | 9876
+------------+---------+-------+---------+------------+
| 32-3456 | Date |... | 3234 | 8765
So to clarify, in case this is still messy, if the Project Number matches Sheet1, then it takes column 6 from Sheet1, and the same for column 7.
I wound up doing this with VLOOKUP. So it looked something like:
=IFERROR(IFERROR(VLOOKUP(RC,'GROUP1'!A:O,6, FALSE),VLOOKUP(RC,'GROUP2'!A:O,6, FALSE),"")
Much clearer now and thanks for posting the columns. It appears as if though your If statement is returning "False" value and that's why the column is not populating.
However, I think you will need to post more of your code as it is currently not possible to debug it without knowing the values of Row, StartColumn, & RowTransfer.
But your code aside for a second, let me see if I understand correctly:
You check if the "Project Number" in A2 of the results sheet is matching the "Project Number" of A2 in Sheet1. If not then you check A3, A4, A5 of Sheet1 until you find a match.
If no match is found you start looking the same way in Sheet2.
Once the match is found, let say in A5 of Sheet1, you take the values of Columns 2-7 of the corresponding row in Sheet1 and copy them to the row with the same "Project Number" in the results sheet.
Please confirm if I understand you correctly so maybe a I can try and put together a code. Also, it would be helpful if you explain what is the reason for having 2 sheets (Sheet1 & Sheet2) as opposed to having just 1.
I think what I'm trying to do is pretty basic, but I'm brand new to VBA so I'm getting stuck and the answers I've found are close, but not quite right.
I have a list of row entries, like this:
1 4 32 2 4
2 6 33 1 3
1 4 32 2 4
4 2 30 1 5
Notice that rows 1 and 3 are duplicates. I'd like to only have a single instance of each unique row but I don't want to just delete the duplicates, I want to report how many of each type there are. Each row represents an inventory item, so deleting duplicate entries without indicating total quantity would be very bad!
So, my desired output would look something like this, where the additional 6th column counts the total number of instances of each item:
1 4 32 2 4 2
2 6 33 1 3 1
4 2 30 1 5 1
My data sets are larger than just these 5 columns, they're closer to 10 or so, so I'd like to put that last column at the end, rather than to hardcode it to the 6th column (i.e., column "F")
Update:
I found some code that worked with minor tweaking, and it worked this morning, but after messing around with some other macros, when I came back to this one it was telling me that I have a "compile error, wrong number of arguments or invalid property assignment" and it seemed to be unhappy with the "range". Why would working code stop working?
Sub mcrCombineAndScrubDups2()
For Each a In range("A1", Cells(Rows.Count, "A").End(xlUp))
For r = 1 To Cells(Rows.Count, "A").End(xlUp).Row - a.Row
If a = a.Offset(r, 0) And a.Offset(0, 1) = a.Offset(r, 1) And a.Offset(0, 2) = a.Offset(r, 2) Then
a.Offset(0, 4) = a.Offset(0, 4) + a.Offset(r, 4)
a.Offset(r, 0).EntireRow.Delete
r = r - 1
End If
Next r
Next a
End Sub
Assuming that your data starts from A1 on a worksheet named ws1, the following code removes the duplicated rows. Not by shifting the whole table but deleting the entire row.
Sub deletedupe()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim row1 As String
Dim row2 As String
i = 1
j = 1
k = 1
Do While Sheets("ws1").Cells(i, 1).Value <> ""
row1 = ""
j = 1
Do While Sheets("ws1").Cells(i, j).Value <> ""
row1 = row1 & Sheets("ws1").Cells(i, j).Value & " "
j = j + 1
Loop
k = i + 1
Do While Sheets("ws1").Cells(k, 1).Value <> ""
row2 = ""
j = 1
Do While Sheets("ws1").Cells(k, j).Value <> ""
row2 = row2 & Sheets("ws1").Cells(k, j).Value & " "
j = j + 1
Loop
If row1 = row2 Then
Sheets("ws1").Rows(k).EntireRow.Delete
Else
k = k + 1
End If
Loop
i = i + 1
Loop
End Sub
I am receiving a large file 500k+ lines but all the content is in column A. I need to run a macro that will transpose the data into matrix form but will only create a new row when it finds "KEY*" in the ActiveCell. For example:
| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359 | skj | 487 |y| 2985789 |
The above data in my file would originally look like this in column A:
KEY 4759839
asljhk
35049
sklahksdjf
KEY 359
skj
487
y
2985789
Considerations:
Blank cells need to be transposed as well, so the macro cant stop based on emptyCell
The number of cells between KEY's is not constant so it actually needs to read the cell to know if it should create a new row
It can either stop based on say 20 empty cells in a row or prompt for a max row number
(Optional) It would be nice if there was some sort of visual indicator for the last item in a row so that its possible to tell if the last item(s) were blank cells
I searched around and found a macro that had the same general theme but it went based on every 6 lines and I did not know enough to try to modify it for my case. But in case it helps here it is:
Sub kTest()
Dim a, w(), i As Long, j As Long, c As Integer
a = Range([a1], [a500000].End(xlUp))
ReDim w(1 To UBound(a, 1), 1 To 6)
j = 1
For i = 1 To UBound(a, 1)
c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
If c = 6 Then j = j + 1
Next i
[c1].Resize(j, 6) = w
End Sub
I would greatly appreciate any help you can give me!
This works with the sample data you provided in your question - it outputs the result in a table starting in B1. It runs in less than one second for 500k rows on my machine.
Sub kTest()
Dim originalData As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim countKeys As Long
Dim countColumns As Long
Dim maxColumns As Long
originalData = Range([a1], [a500000].End(xlUp))
countKeys = 0
maxColumns = 0
'Calculate the number of lines and columns that will be required
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
countKeys = countKeys + 1
maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
countColumns = 1
Else
countColumns = countColumns + 1
End If
Next i
'Create the resulting array
ReDim result(1 To countKeys, 1 To maxColumns) As Variant
j = 0
k = 1
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
j = j + 1
k = 1
Else
k = k + 1
End If
result(j, k) = originalData(i, 1)
Next i
With ActiveSheet
.Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
End With
End Sub
Tested and works:
Sub test()
Row = 0
col = 1
'Find the last not empty cell by selecting the bottom cell and moving up
Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is
'loop through the data
For i = 1 To Max
'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
If (Left(Range("A" & i).Value, 3) = "KEY") Then
Row = Row + 1
col = 1
End If
Cells(Row, col).Value = Range("A" & i).Value
If (i > Row) Then
Range("A" & i).Value = ""
End If
col = col + 1
Next i
End Sub