I'm trying to make a new table from some information in a table, with an
structure like this:
A B D G L
A B D G M
A B D H N
A B E I O
A C F J P
A C F K Q
So, It returns a table with rows like this:
A | D | B | "G: L M H: N"
The original data base has the following columns:
Role
Object
Instance
Field
Value
The new table should be: Role, Instance, Object, Object value. So, if the object is the same, it means it's a new instance for that object, an it's new value will be every field(with all it's values), like the example above.
This is the code (The text is supposed to be in the first 5 columns, and it should be returned from the G column):
Sub instancia()
Dim fila, filacol As Long
Dim cad, c As String
fila = 2
filacol = 2
Do
cad = ""
Cells(filacol, 7) = Cells(fila, 1)
Cells(filacol, 8) = Cells(fila, 3)
Cells(filacol, 9) = Cells(fila, 2)
Do
c = " "
cad = cad + Cells(fila, 4).Value + ": "
Do
c = c + Cells(fila, 5).Value + " "
fila = fila + 1
Loop While Cells(fila, 4) = Cells(fila + 1, 4)
cad = cad + c
Loop While Cells(fila, 2).Value = Cells(fila + 1, 2).Value
Cells(filacol, 10).Value = car
filacol = filacol + 1
Loop While Cells(fila + 1, 2) <> Empty
End Sub
It does't work because it says there's a problem with execution time, but trying to debug, I found out that the variable 'fila' never changes. What can I do?
Related
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.
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
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
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
Can someone please help me create a macro that will search two columns on a worksheet for a list of conditions and mark true/false on the third column. (office 2010)
e.g.
Column A would have the following values: 1111,1,2,3,3,4,...
Column B would have the following values: O,A,Y,A,S,3Y,...
If the following matching conditions are met, the column C would mark as TRUE, otherwise FALSE.
A B
1111 = O
0 = Y
1 = A
2 = S
3 = 3YRY
4 = Q
6 = B
12 = M
13 = V
360 = D
CONDITION RULES:
IF column A = 1111 AND column B = O
OR
IF column A = 0 AND column B = Y
OR
IF column A = 1 AND column B = A
OR
IF column A = 2 AND column B = S
OR
IF column A = 3 AND column B = 3YR
OR
IF column A = 4 AND column B = Q
OR
IF column A = 6 AND column B = B
OR
IF column A = 12 AND column B = M
OR
IF column A = 13 AND column B = V
OR
IF column A = 360 AND column B = D
THEN COLUMN C = "TRUE" ELSE "FALSE"
This should match more closely what you're wanting to accomplish, any questions about what's happening here let me know.
Option Base 1
Sub testCriteria()
'arrays for criteria r, r2. Array for T/F r3
Dim r, r2, r3(10, 1)
'iterators for loop and variable for output column
Dim i As Long, j As Long, c As Long
'column for output of t/f
c = 3
'location of criteria cells h1 through i10
r = [h1:i10]
'location of comparison
r2 = [a1:b10]
'loop through rows of rows to check (r2) and compare with all rows from criteria (r)
For i = LBound(r2) To UBound(r2)
For j = LBound(r) To UBound(r)
If CStr(r(j, 1)) = CStr(r2(i, 1)) _
And CStr(r(j, 2)) = CStr(r2(i, 2)) _
Then r3(i, 1) = "TRUE"
Next j
If Not r3(i, 1) Then r3(i, 1) = "FALSE"
Next i
'reusing iterators for array limits
i = LBound(r3): j = UBound(r3)
'loading t/f array into api
Range(Cells(i, c), Cells(j, c)) = r3
End Sub