I have a column where some cells have values but most are blank.
What I want is to fill in the blanks by spreading the values. For example
1
blank
blank
3
blank
5
would be changed to
1
1
1
1
2.5
2.5
Here's what I have so far:
Sub ()
Set z = range("numbers")
For n = 2 To z.Rows.Count
x = z.Cells(n, 1)
If IsEmpty(x) Then
'do nothing
ElseIf x.End(xlUp).Row < z.Cells(1, 1).Row Then
k = x / (x.Row - z.Cells(1, 1).Row + 1)
z(Cells(1, 1), Cells(n, 1)).Offset(0, 5) = k
Else
k = x / (x.Row - x.End(xlUp).Row + 1)
z(Cells(x.End(xlUp), 1), Cells(n, 1)).Offset(0, 5) = k
End If
Next n
There are many problems with this code. There is an 'object required' error on the line of the for loop. Also endxlup would get me the final value rather than the first value I meet going up. I just wanted to show my efforts.
Taking a wild guess, but you want go from bottom to top, and where the there are blank cells, evenly distribute the value of the last filled cell.
Going to take a stab with top-of-head code, untested:
dim i as long, lr as long, j as double, k as long
lr = cells(rows.count,1).end(xlup).row
j = 0 'value to be divided
k = 0 'number of cells to divide j across
for i = lr to 2 step -1 'assumes header in row 1
if cells(i,1).value <> "" AND j <> 0 then
if cells(i,1).value <> "" then j = cells(i,1).value
if cells(i,1).value = "" then k = k+1
else
range(cells(i+1,1),cells(i+1+k,1)).value = j/k
j = 0
k = 0
end if
next i
Related
I've limited knowledge in maths so pardon the terms if i'm mistaken.
I need to create all possible combinations from multiple sets with at least 1 item included from that set.
- SetA: [1, 2, 3, 4, 5, 6, 7]
- SetB: [a, b, c, d]
- SetC: [!, #, #, $, %]
Example Output:
- [1,a,!]
- [1,2,a,c,#]
- [1,2,3,4,5,6,7,a,b,c,d,!,#,#,$,%]
Is there a specific combination formula for this since i can only come up with nested loops and i'm not sure if it is even correct.
#barrycarter had good idea of obtaining the power set. However, we don't need to reject anything as we are not getting the power set of the union of sets (this would end up being inefficient as there will be many rejects as the number of sets grows). We simply get the power set of each set, then get all combinations of those power sets. The subroutine below, works for an arbitrary number sets of arbitrary length.
Sub CreateAllCombs()
Dim ArrayOfPowSets() As Variant, mySet() As Variant, ArrCounter() As Long, myPS As Variant
Dim myCombs() As Variant, nextComb() As Variant, ParentComb() As Variant, ArrMax() As Long
Dim i As Long, j As Long, k As Long, count1 As Long, count2 As Long, CombExist As Boolean
Dim tempCol As Long, myMax As Long, maxRow As Long, totalCombs As Long
With ActiveSheet
maxRow = .Cells(.Rows.count, "A").End(xlUp).Row
End With
ReDim ArrayOfSets(1 To maxRow, 1 To 1)
ReDim ArrCounter(1 To maxRow)
ReDim ArrMax(1 To maxRow)
myMax = 0
For i = 1 To maxRow
With ActiveSheet
tempCol = .Cells(i, .Columns.count).End(xlToLeft).Column
End With
ReDim mySet(1 To tempCol)
For j = 1 To tempCol: mySet(j) = Cells(i, j): Next j
myPS = PowerSet(mySet)
ArrMax(i) = UBound(myPS)
If ArrMax(i) > myMax Then
myMax = ArrMax(i)
ReDim Preserve ArrayOfPowSets(1 To maxRow, 1 To ArrMax(i))
End If
For j = 1 To ArrMax(i)
ArrayOfPowSets(i, j) = myPS(j)
Next j
ArrCounter(i) = 1
Next i
CombExist = True
totalCombs = 0
Do While CombExist
count1 = 1
ReDim ParentComb(1 To 1)
For i = 1 To maxRow - 1
For j = 1 To UBound(ArrayOfPowSets(i, ArrCounter(i)))
ReDim Preserve ParentComb(1 To count1)
ParentComb(count1) = ArrayOfPowSets(i, ArrCounter(i))(j)
count1 = count1 + 1
Next j
Next i
For i = 1 To ArrMax(maxRow)
count2 = count1
nextComb = ParentComb
For j = 1 To UBound(ArrayOfPowSets(maxRow, i))
ReDim Preserve nextComb(1 To count2)
nextComb(count2) = ArrayOfPowSets(maxRow, i)(j)
count2 = count2 + 1
Next j
totalCombs = totalCombs + 1
ReDim Preserve myCombs(1 To totalCombs)
myCombs(totalCombs) = nextComb
Next i
k = maxRow - 1
Do While (ArrCounter(k) >= ArrMax(k))
ArrCounter(k) = 1
k = k - 1
If k = 0 Then Exit Do
Loop
If k > 0 Then ArrCounter(k) = ArrCounter(k) + 1 Else CombExist = False
Loop
Sheets("Sheet2").Select
For i = 1 To totalCombs
For j = 1 To UBound(myCombs(i))
Cells(i, j) = myCombs(i)(j)
Next j
Next i
End Sub
I used a slightly modified version of the power set function written by John Coleman found here
Function PowerSet(Items As Variant) As Variant
Dim PS As Variant
Dim i As Long, j As Long, k As Long, n As Long
Dim subset() As Variant
n = UBound(Items)
ReDim PS(1 To 1 + 2 ^ n - 2)
For i = 1 To 2 ^ n - 1
ReDim subset(1 To n)
k = 0
For j = 0 To n - 1
If i And 2 ^ j Then
k = k + 1
subset(k) = Items(j + 1)
End If
Next j
ReDim Preserve subset(1 To k)
PS(i) = subset
Next i
PowerSet = PS
End Function
This assumes that SetA is on row 1, SetB is on row 2, etc. Observe:
Additionally, the reader should be warned that this may take a while as there is over 14 million possible combinations.
(2^3 - 1) * (2^5 - 1) * (2^16 - 1) = 7 * 31 * 65535 = 14221095
Also, all combinations are written out generically to Sheet2.
I think i found my solution please verify.
First, for each sets, i created all possible combinations and checked the length using the sum of pascal triangle without the null or this formula:
n!/(r!(n-r)!) - 1
e.g.
SetB: [a, b, c, d] -> [a,b,c,d,ab,ac,ad,bc,bd,cd,abc,abd,acd,bcd,abcd]
After creating all possible combinations for each sets, I just used product rule
[SetA] X [SetB] X [SetC]
Which resulted for all possible combinations for:
multiple items
multiple sets
no repeat
no order
Reference: https://www.mathsisfun.com/combinatorics/combinations-permutations-calculator.html
EDIT1: checking for amount of combinations per set can also be (2^n)-1 where n= length of set
Have you tried using nested for loops.
Sub Hello()
MsgBox ("Hello, world!")
Dim arr1
arr1 = Array("1", "2", "3")
Dim arr2
arr2 = Array("a", "b", "c")
Dim arr3
arr3 = Array("!", "#", "$")
For i = 0 To UBound(arr1)
For j = 0 To UBound(arr2)
For k = 0 To UBound(arr3)
MsgBox (arr1(i) & arr2(j) & arr3(k))
Next
Next
Next
End Sub
I have been working on a macro that Archives: it selects rows with the right cell value and move them to another tab (while deleting the rows in the tab of origin).
My macro was working perfectly fine, but I decided to change my file and have different new tabs. When I computed my Macro in my new tabs, and it works on the right rows, and deletes them, but does not copy them in my "Archive tab" :
Sub Archive_Ongoing()
Test 2 : works for 2 arguments.
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("B90_Projects_OnGoing").UsedRange.Rows.Count
J = Worksheets("B90_Projects_Archived").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("B90_Projects_Archived").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("B90_Projects_OnGoing").Range("O1:O" & I)
Set yRg = Worksheets("B90_Projects_OnGoing").Range("T1:T" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Closed" And CStr(yRg(K).Value) <> "" Then
xRg(K).Selection.Copy Destination:=Worksheets("B90_Projects_Archived").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Closed" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub'
Any one would be able to explain why?
Because you're decrementing your K variable within the FOR loop, which is also incrementing it. Your K variable never changes. Comment out K = K - 1 and report back?
If you're doing that on purpose to evaluate / delete a single line and shift the next values up then you might want to have a K2 variable that you increment like this:
For K = 1 To xRg.Count
If CStr(xRg(K - K2).Value) = "Closed" And CStr(yRg(K - K2).Value) <> "" Then
xRg(K - K2).Selection.Copy Destination:=Worksheets("B90_Projects_Archived").Range("A" & J + 1)
xRg(K - K2).EntireRow.Delete
If CStr(xRg(K - K2).Value) = "Closed" Then
K2 = K2 + 1
End If
J = J + 1
End If
Next
Sub MultipleSearch()
Dim aNum(), aTabl(), aRes()
Dim i As Long, k As Long, n As Long
With Worksheets("List1")
i = .Cells(.Rows.Count, "A").End(xlUp).Row
aTabl = .Range("A1:G" & i).Value
End With
With Worksheets("List2")
i = .Cells(.Rows.Count, "D").End(xlUp).Row
aNum = .Range("D1:D" & i).Value
ReDim aRes(1 To i + 3, 1 To 1)
aRes(1, 1) = .Range("K1").Value
End With
For i = 2 To UBound(aNum)
n = i
For k = 2 To UBound(aTabl)
If aTabl(k, 1) <> Empty Then
If aNum(i, 1) = aTabl(k, 1) Then
aRes(n, 1) = aTabl(k, 7): n = n + 1
End If
End If
Next k
Next i
Worksheets("List2").Range("K1").Resize(UBound(aRes), 1).Value = aRes
End Sub
Hi. I have a code that lookup value on Picture 1 in 4.column and value on Picture 2 in 1.column and when it matches it returns value from Picture 2. from 8.column as you see.
I need to make a change. I need to return value from 8.column in other way.
When its the first match of 26054112 i need to return the first number from 8.column - -10629425,25
When its second match of 26054112 i need to return the second number - -1549761,31
And so on...
I want to loop each number in column A through column B.
If there is a match, that number to be looped through column C.
If there is a match, I want the results to be returned in columns E and F.
Each column will have a variable amount of rows. There can also be multiple results.
In my example the number 1 from column A is looped through column B. If a match is found 1 is now looped through column C. If there is a match then columns E and F = C and D.
Example
If your data is arranged like bellow picture,then the code would be like this.
Sub test()
Dim vDB1, vDB2, vDB3, vR()
Dim i As Long, j As Long, k As Long, n As Long
vDB1 = Range("a2", Range("a" & Rows.Count).End(xlUp))
vDB2 = Range("b2", Range("b" & Rows.Count).End(xlUp))
vDB3 = Range("c2", Range("d" & Rows.Count).End(xlUp))
Range("e2:f2").Resize(Rows.Count - 1) = Empty
For i = 1 To UBound(vDB1, 1)
For j = 1 To UBound(vDB2, 1)
If vDB1(i, 1) = vDB2(j, 1) Then
For k = 1 To UBound(vDB3, 1)
If vDB1(i, 1) = vDB3(k, 1) Then
n = n + 1
ReDim Preserve vR(1 To 2, 1 To n)
vR(1, n) = vDB3(k, 1)
vR(2, n) = vDB3(k, 2)
End If
Next
End If
Next j
Next i
If n > 0 Then
Range("e2").Resize(n, 2) = WorksheetFunction.Transpose(vR)
End If
End Sub
Here is a code that should do the job. But if Tab1/Tab2 values are not unique then it might do a lookup multiple times. For example if there was 1 in place of 9 in Tab 2 it would show the row with 1 twice in tab 4. If you want to avoid that you will need to modify my code
Set tab1_list = Sheets("sheet1").Range("B6:B10")
Set tab2_list = Sheets("sheet1").Range("C6:C10")
Set tab3_list_lookup = Sheets("sheet1").Range("E6:E10")
Set Tab3_List_value = Sheets("sheet1").Range("F6:F10")
Set output_location = Sheets("sheet1").Range("H6")
For Each cell1 In tab1_list
For Each cell2 In tab2_list
If cell1.Value = cell2.Value Then
For index_no = 1 To tab3_list_lookup.Cells.Count
If tab3_list_lookup.Cells(index_no).Value = cell2.Value Then
output_location.Value = tab3_list_lookup.Cells(index_no).Value
output_location.Offset(0, 1) = Tab3_List_value.Cells(index_no).Value
Set output_location = output_location.Offset(1, 0)
End If
Next index_no
End If
Next cell2
Next cell1
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