Excel VBA how to set number sequence to start at middle of the row? - vba

I previously have a Excel sheet with VBA coding that fills column, row 1 to 10 with the number 1, row 11 to 20 with number 2 and so on. The code I've used is as follows:
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Sheet1").Cells(c, 1) = ID
ActiveWorkbook.Sheets("Sheet1").Cells(c + 1, 1) = ID
c = c + 1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
Now I want to change it so that the code starts at row 3 onwards. Meaning row 3 to 12 = 1, row 13 to 22 = 2 and so on. So I changed the 'For' statement to:
For c = 3 To 34
But what happens is that the number 1 appears from row 3 to row 10, and then continues with number 2 in row 11 to 20. Not what I was expecting.
Therefore, what would be the best method of changing the code?

If you want exactly the same output but two rows lower, you can use:
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Sheet1").Cells(c + 2, 1) = ID
ActiveWorkbook.Sheets("Sheet1").Cells(c + 3, 1) = ID
c = c + 1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
If you still only want to go to row 34 but start in row 3, change the 34 to 32 in the above code.
You can also do it without looping and this is easier to adjust the parameters:
Sub fill()
Const NUMBER_OF_ROWS As Long = 34
Const START_ROW As Long = 3
Const ID As Long = 1
Const NUMBER_IN_GROUP As Long = 10
With ActiveWorkbook.Sheets("Sheet1").Cells(START_ROW, 1).Resize(NUMBER_OF_ROWS)
.Value = .Parent.Evaluate("INDEX(INT((ROW(" & .Address & ")-" & START_ROW & ")/" & _
NUMBER_IN_GROUP & ")+" & ID & ",)")
End With
End Sub

When i understand you write, this should work:
You can use the loop how you did at the beginning. and just add plus 2 to c in the ActiveWorkbook.Sheets("Tabelle1").Cells(c + 2, 1) = ID
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Tabelle1").Cells(c + 2, 1) = ID
ActiveWorkbook.Sheets("Tabelle1").Cells(c + 3, 1) = ID
c= c+1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub

something like that should be the simplest way:
Sub fill()
Dim i As Integer
Dim j As Integer
For i = 1 To 4
For j = 1 To 10
ActiveWorkbook.Sheets("Sheet1").Cells(j + (i - 1) * 10 + 2, 1) = i
Next j
Next i
End Sub
EDIT:
No, the simplest way would be type formula into A3:
=ROUNDDOWN(((ROW()-3))/10,0)+1
end drag it donw.

Related

Test if a permutation of a number exists in a collection

I'm trying to list all numbers with 3 digits where the individual digits sum to a given number.
So far I can return a list of all numbers using this Visual Basic code:
target = 17
i = 1
j = 1
k = 1
Do While i < 10
Do While j < 10
Do While k < 10
r = i + j + k
If r = target Then
If i <> j And j <> k And k <> i Then
lsNumbers.Add(i & j & k )
End If
End If
k += 1
Loop
If k = 10 Then k = 1
j += 1
Loop
If j = 10 Then j = 1
i += 1
Loop
But I want only unique, non repeating combinations.
For example for the target number 17:
179, 197, 269, 278, 287...
I want to be able to test the current number before I add it to the list, to check if it is a combination of a number already in the list - so 197 would fail because of 179, and 287 would fail because of 278
Observations
Just curious, is excluding the 0 digit on purpose?
To iterate through the possible digits, a well suited instruction pair is FOR NEXT. Definitely simpler than the DO WHILE that you used.
Loop
If k = 10 Then k = 1
Loop
If j = 10 Then j = 1
Upon loop completion, the iterator is sure to contain 10. The IF is redundant.
Solution
In order to check if a number, that obeys the condition, is unique in the sense that it is not composed of the same 3 digits as an already validated number, you could consult a 3-D array. If the new number corresponds to a non-zero element in this array, it means that the new number would be using the same digits as an earlier number. That's reason to reject it.
Next code runs in QBasic. You'll have no trouble rewriting it for Visual BASIC.
DIM r%(1 TO 9, 1 TO 9, 1 TO 9)
FOR i% = 1 TO 9
FOR j% = 1 TO 9
FOR k% = 1 TO 9
r%(i%, j%, k%) = 0
NEXT
NEXT
NEXT
target% = 17
FOR i% = 1 TO 9
FOR j% = 1 TO 9
FOR k% = 1 TO 9
IF i% + j% + k% = target% THEN
IF r%(i%, j%, k%) = 0 THEN
PRINT i% * 100 + j% * 10 + k%; " ";
r%(i%, j%, k%) = 1 ' Could do without this one because of the ascending order
r%(i%, k%, j%) = 1
r%(j%, i%, k%) = 1
r%(j%, k%, i%) = 1
r%(k%, i%, j%) = 1
r%(k%, j%, i%) = 1
END IF
END IF
NEXT
NEXT
NEXT
This is my output of valid numbers:
179 188 269 278 359 368 377 449 458 467 557 566

VBA code to calculate pick-up% up ownership chain

First time poster!
I am hoping someone can help with my a VBA code. I have some experience with VBA coding, but I don't have the knowledge or expertise to handle the task I am facing.
I have a report of entities and their owners.
With this report, you can follow the ownership chain of each entity.
Here is an example of the Report:
Entity #, Entity Name, Parent #, Parent Name, Owner % Inside
100 Entity 1 200 Entity2 100 Yes
200 Entity 2 300 Entity 3 50 Yes
200 Entity 2 400 Entity 4 50 Yes
500 Entity 5 600 Entity 6 100 Yes
600 Entity 6 700 Entity 7 25 Yes
600 Entity 6 800 Entity 8 25 Yes
600 Entity 6 900 Entity 9 50 Yes
800 Entity 8 1200 Entity 12 100 Yes
900 Entity 9 1000 Entity 10 25 No
900 Entity 9 1100 Entity 11 75 Yes
So basically, Entity one is owned 100% by Entity 2. Entity 2 is owned by 50% by Entity 4 and Entity 5. Entity 3 and 4 is not owned by any affiliates. Entity 5 is owned 100% by Entity 6. Entity 6 is owned 25% to Entity 7, 25% by entity 8 and 50% by entity 9 . Entity 8 is owned 100% by entity 12. Entity 9 is owned 25% by entity 10 and 75% by Entity 11. Entity 10 is not an affiliate.
The code should calculate the Pick-up % of the lower entity [100 & 500]. In this case, the Pick-up % for 100 will be 100% because all of the entities in the chain are affiliates. While the pick-up% for 500 is 75% because entity 1000 is not an affiliate.
I have started and stop writing this code at least ten times and each time I get stuck along the way. Here is my issue: In reality, the chain could go up 7 to 8 levels. Once I get back past level two, I do not know how to calculate the pickup % of the entity has multiple owners. For instance, if you look at my table up top. Once I calculate the ownership for 600, I can't figure how to extend the chain to owners of 800 and 900.
Here is a diagram of the ownership structures:
Here is the code I have so far:
Sub ownerinterest()
Sheets("Copyii").Activate
Set dict3 = New Dictionary
nRowCount = Cells(Rows.Count, "B").End(xlUp).Row
arowcount = Cells(Rows.Count, "AA").End(xlUp).Row
ReportArray = Range(Cells(1, "AA"), Cells(arowcount, "AB"))
For i = 2 To nRowCount
GemC = Left(Cells(i, "a"), 5)
ParentC = Cells(i, "d")
PctC = (Cells(i, "J") / 100)
OwnerC = Cells(i, "h")
EntityC = Cells(i, "b")
d = i
If (Not (dict3.Exists(GemC))) Then
Set GEMclass = New Gclass
dict3.Add GemC, GEMclass
dict3(GemC).e = EntityC
dict3(GemC).P = ParentC
dict3(GemC).O = OwnerC
dict3(GemC).Num = d
dict3(GemC).g = GemC
End If
Call countlevels
dict3(GemC).Pct = PctC
Next i
Call Calculepickup
End Sub
Sub countlevels()
For e = LBound(ReportArray, 1) To UBound(ReportArray, 1)
If GemC = ReportArray(e, 1) Then
If ReportArray(e, 2) > 1 Then
Pcount = ReportArray(e, 2)
PctC = 0
For f = 1 To Pcount
TPct = Cells(i + f - 1, "J")
PctC = TPct + PctC
Next f
Exit For
Else
PctC = PctC
Exit For
End If
End If
Next e
End Sub
Sub Calculepickup()
Dim g As Long, h As Integer, j As Integer, m As Integer
Dim NewGem As String
Dim Tpct2 As Double
Dim MainArray() As Variant
Dim MainRange As Range
m = Cells(Rows.Count, "A").End(xlUp).Row
Set MainRange = Range("a1:J" & m)
MainArray() = MainRange
For g = 0 To dict3.Count - 1
Set GEMclass = dict3.Items(g)
ReportGEM = GEMclass.P
GemC = GEMclass.g
PctC = GEMclass.Pct
Debug.Print GemC & "|" & ReportGEM & "|" & PctC
For h = 0 To dict3.Count - 1
If (dict3.Exists(ReportGEM)) Then
NewGem = ReportGEM
For j = LBound(ReportArray) To UBound(ReportArray)
If NewGem = ReportArray(j, 1) Then
If ReportArray(j, 2) > 1 Then
Pcount = 0
Pcount = ReportArray(j, 2)
Tpct2 = 0
Dim K As Integer
For K = LBound(MainArray, 1) To UBound(MainArray, 1)
Dim GEMk As String
GEMk = MainArray(K, 1)
If NewGem = GEMk Then
Debug.Print GEMk & "|" & K
For f = 1 To Pcount
TPct = Cells(K + f - 1, "J")
Debug.Print TPct
Tpct2 = TPct + Tpct2
Debug.Print Tpct2
Next f
Exit For
End If
Next K
End If
End If
Next j
End If
Next h
Next g
End Sub
I believe that the following will do what you want. (It's probably the only real way to associate an "ownership percentage" based on multiple parents each with their own "ownership percentage".)
Public entities As New Dictionary
Public MainArray() As Variant
'I have assumed that the table you posted in the question represented columns A to F of an Excel spreadsheet.
'Change the following constants so it suits your actual layout.
Const colEntity As Integer = 1 ' Assumed column A
Const colParent As Integer = 3 ' Assumed column C
Const colPct As Integer = 5 ' Assumed column E
Const colInside As Integer = 6 ' Assumed column F
Sub Calculepickup()
Dim g As Integer, r As Integer, m As Integer
Dim MainRange As Range
m = Cells(Rows.Count, "A").End(xlUp).Row
Set MainRange = Range("a2:J" & m)
MainArray() = MainRange
'Add each entity to a dictionary, and flag the percentage as uncalculated by setting it to -1
For g = 1 To UBound(MainArray, 1)
If Not entities.Exists(MainArray(g, colEntity)) Then
entities.Add MainArray(g, colEntity), -1
End If
If Not entities.Exists(MainArray(g, colParent)) Then
If MainArray(g, colInside) = "No" Then
'If the entity isn't "inside" store the fact that it is 0% owned
entities.Add MainArray(g, colParent), 0
Else
entities.Add MainArray(g, colParent), -1
End If
End If
Next
r = 0
For Each e In entities.Keys
CalculatePct e
'Write results to columns N and O just so that we can see them
r = r + 1
Cells(r, 14) = e
Cells(r, 15) = entities(e)
Next
End Sub
Sub CalculatePct(e As Variant)
Dim g As Integer
Dim pct As Double
Dim Owned100Pct As Boolean
If entities(e) < 0 Then
pct = 0
Owned100Pct = True ' Keeps track if the entity exists in the table other than as a parent
For g = 1 To UBound(MainArray, 1)
If MainArray(g, colEntity) = e Then
Owned100Pct = False
If entities(MainArray(g, colParent)) = -1 Then
'If we don't know the parent's ownership percentage, go and calculate it
CalculatePct MainArray(g, colParent)
End If
pct = pct + CDbl(MainArray(g, colPct)) / 100 * entities(MainArray(g, colParent))
End If
Next
If Owned100Pct Then
'Assume 100% owned if we don't know the parentage
'("Outside" entities won't go through here as they are already set to 0%)
entities(e) = 1
Else
'Store the entity's percentage
entities(e) = pct
End If
End If
End Sub

vba array element removal

j = LBound(arrayTime)
Do Until j = UBound(arrayTime)
j = j + 1
b = b + 1
cnc = b + r
MsgBox cnc
If cnc > 7 Then
b = 0
r = 0
cnc = b + r
End If
numMins = Sheet5.Cells(cnc + 3, 2) - arrayTime(j)
If numMins < 0 Then
g = g + 1
ReArrangeArray arrayTime, j
'ReDim Preserve arrayTime(numrows - 1 + g)
'arrayTime(numrows - 1 + g) = arrayTime(j)
'MsgBox (arrayTime(numrows - 1 + g))
Else
Sheet5.Cells(cnc + 3, 2) = numMins
End If
Loop
If the if statement is true I want to be able to put the array value at the end of the array and remove that value from its current spot. As the code is, it just adds it to the end and increases the size of the array from 12 to 13. How can I get the array to remain size 12 and still place the value at the end of the array and then remove it from its original position? I do not want to touch the array values in front. Just want to take that value and move it to the end.
For instance
array(1,2,3,4,5)
If statement
j on third loop.
array(j)=3
end array should be
array(1,2,4,5,3)
You could use a helper Sub like this one:
Sub ReArrangeArray(inputArray as Variant, indexToSwap as long)
Dim I As Long
Dim tempVal As Variant
If indexToSwap >= LBound(inputArray) And indexToSwap < UBound(inputArray) Then
tempVal = inputArray(indexToSwap)
For I = indexToSwap To UBound(inputArray) - 1
inputArray(i) = inputArray(i + 1)
Next I
InputArray(UBound(inputArray)) = tempVal
End If
End Sub
To be called by your main Sub as follows:
ReArrangeArray arrayTime, j

VBA For each loop not looping how i want

I have the following loop
r = 4
c = 4
Set userBeanList = XMLDOC.SelectNodes("/response/responseBody/responseList/item[recordType='TPI']/*[not(self::catch or self::reprive or self::cate or self::reet or self::aarg or self::crane)]")
For a_counter = 1 To 7
For Each userbean In userBeanList
Sheets("Sheet2").Cells(r, c) = userbean.nodeName
Sheets("Sheet2").Cells(r + 1, c) = userbean.Text
r = r + 2
a_counter = a_counter + 1
If (a_counter = 7) Then Exit For
Next userbean
c = c + 1
r = 4
a_counter = 1
Next a_counter
which basically goes over my nodes prints the node name in row 4 followed by the node value in the cell below row 5, this repeats 6 times so that i get the node name followed by the node value in a list in a spreadsheet. I then have a counter which when it reaches 7 exits the for loop increments the column by 1 resets the row back to 4 and this repeats. However the For Each userbean in userBeanList appears to reset itself back to the start so rather than get the next userbean it gets the first one again, How can i amend my code below to get the next userbean in my nodes?
Try this:
r = 4
c = 4
a_counter = 1
Set userBeanList = XMLDOC.SelectNodes("/response/responseBody/responseList/item[recordType='TPI']/*[not(self::catch or self::reprive or self::cate or self::reet or self::aarg or self::crane)]")
For Each userbean In userBeanList
Sheets("Sheet2").Cells(r, c) = userbean.nodeName
Sheets("Sheet2").Cells(r + 1, c) = userbean.Text
r = r + 2
a_counter = a_counter + 1
If a_counter >= 7 Then
c = c + 1
r = 4
a_counter = 1
End If
Next userbean
You are trying to use a_counter as a for loop and as a separate counter you do not need the for loop it gets in the way.
Edit:
You really do not need the a-Counter at all. you can use the r value to check when 6 have been done:
r = 4
c = 4
Set userBeanList = XMLDOC.SelectNodes("/response/responseBody/responseList/item[recordType='TPI']/*[not(self::catch or self::reprive or self::cate or self::reet or self::aarg or self::crane)]")
For Each userbean In userBeanList
Sheets("Sheet2").Cells(r, c) = userbean.nodeName
Sheets("Sheet2").Cells(r + 1, c) = userbean.Text
r = r + 2
If r > 14 Then
c = c + 1
r = 4
End If
Next userbean

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!