I want to loop over 12 shapes, all with a group of a picture and a textbox.
The code seems to be correct, but it does not work.
Word/VBA is selecting the shapes multiple times and with a different order each time:
Dim sh As Shape
Dim i As Integer
Dim li As Integer
i = 0
Debug.Print ActiveDocument.Shapes.Count
For Each sh In ActiveDocument.Shapes
Debug.Print "ID " + CStr(sh.ID)
i = i + 1
If sh.Type = msoGroup Then
sh.Name = "Group " + CStr(i)
sh.Select
For li = 1 To sh.GroupItems.Count
If sh.GroupItems(li).Type = msoTextBox Then
sh.GroupItems(li).TextFrame.TextRange.Text = CStr(i)
End If
Next
End If
Next
The multiple selection can be viewd using the sh.select
The output the ID for two runs it the following:
12
ID 4
ID 13
ID 3
ID 22
ID 31
ID 19
ID 4
ID 3
ID 31
ID 4
ID 31
ID 31
12
ID 25
ID 28
ID 16
ID 13
ID 19
ID 4
ID 25
ID 16
ID 19
ID 25
ID 19
ID 19
Related
For a computer science homework, with the example of money, I need to print all possible combination of numbers that add up to 15. I have 9 coins of 1GBP, 3 coins of 2GBP and 3 banknotes of 5GBP. The code below does all possible combinations but I only need to print ones where the numbers add up to 15.
Here is the code below.
Dim num(15) As Integer
Dim a%, b%, c%, d%, e%, f%, g%, h%, i%, j%, k%, l%, m%, n%, o%
num(1) = 1
num(2) = 1
num(3) = 1
num(4) = 1
num(5) = 1
num(6) = 1
num(7) = 1
num(8) = 1
num(9) = 1
num(10) = 2
num(11) = 2
num(12) = 2
num(13) = 5
num(14) = 5
num(15) = 5
Dim count As Integer
For a = 0 To 14
For b = 0 To 14
For c = 0 To 14
For d = 0 To 14
For e = 0 To 14
For f = 0 To 14
For g = 0 To 14
For h = 0 To 14
For i = 0 To 14
For j = 0 To 14
For k = 0 To 14
For l = 0 To 14
For m = 0 To 14
For n = 0 To 14
For o = 0 To 14
Console.WriteLine(num(a) & num(b) & num(c) & num(d) & num(e) & num(f) & num(g) & num(h) & num(i) & num(j) & num(k) & num(l) & num(m) & num(n) & num(o))
count += 1
Next o
Next n
Next m
Next l
Next k
Next j
Next i
Next h
Next g
Next f
Next e
Next d
Next c
Next b
Next a
I wrote a code to write all the possible combinations with 3 numbers using a list of numbers.
Dim min, max, mppt1, mppt2, mppt3, reference As Integer
'seting the range of numbers
min = Range("AA3").Value
max = Range("AB3").Value
For mppt1 = min To max
For mppt2 = min To max
For mppt3 = min To max
Range("AA" & reference).Value = mppt1
Range("AB" & reference).Value = mppt2
Range("AC" & reference).Value = mppt3
referencia = reference + 1
Next mppt3
Next mppt2
Next mppt1
This works fine. But then, i need to delete all duplicate combinations (independent of the order)
For example, if i have this combinations:
16 | 17 | 18
16 | 18 | 17
18 | 17 | 17
18 | 16 | 16
After the delete, i should have this output:
16 | 17 | 18
18 | 17 | 17
18 | 16 | 16
How can i put this logic in my code?
Rather than getting rid of the duplicates, why not avoid avoid outputting them to start off with?
Instead of your second and third loops starting from min, have them start from the previous loop variable. Here's a similar working example I mocked up:
Sub Test()
Dim min As Integer, max As Integer
Dim i As Integer, j As Integer, k As Integer
min = 16
max = 18
For i = min To max
For j = i To max
For k = j To max
Debug.Print i, j, k
Next k
Next j
Next i
End Sub
this prints the following into the immediate window:
16 16 16
16 16 17
16 16 18
16 17 17
16 17 18
16 18 18
17 17 17
17 17 18
17 18 18
18 18 18
Try the code below. I added some code to add up the 3 cells and put the answer in column 5. Then I sort by column 5. The next loop uses the totals and deletes any total that is a duplicate each time the total changes.......
Dim min, max, mppt1, mppt2, mppt3, reference As Integer
'seting the range of numbers
min = Range("f1").Value
max = Range("g1").Value
reference = 1
For mppt1 = min To max
For mppt2 = min To max
For mppt3 = min To max
Range("A" & reference).Value = mppt1
Range("B" & reference).Value = mppt2
Range("C" & reference).Value = mppt3
reference = reference + 1
Next mppt3
Next mppt2
Next mppt1
Dim r As Integer
Range("A1:E1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("a1:a27") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:E27")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim Col1 As Integer
Dim Col2 As Integer
Dim Col3 As Integer
Col1 = Cells(1, 1)
Col2 = Cells(1, 2)
Col3 = Cells(1, 3)
r = 2
Do Until Len(Trim(Cells(r, 1))) = 0
DoEvents
startrow = r
Col1 = Cells(r, 1)
Col2 = Cells(r, 2)
Col3 = Cells(r, 3)
r = r + 1
Do While Cells(r, 1) = Col1
DoEvents
If Cells(r, 2) = Col2 And Cells(r, 3) = Col3 Then
Cells(r, 1).EntireRow.Delete
Else
If Cells(r, 2) = Col3 And Cells(r, 3) = Col2 Then
Cells(r, 1).EntireRow.Delete
Else
r = r + 1
End If
End If
Loop
r = startrow + 1
Loop
Cells(1, 5).EntireColumn.ClearContents
Use a dictionary to collect the unique sums as keys and the individual values as an array item then write the arrays back to the worksheet.
Option Explicit
Sub saqwjh()
Dim d As Long, k As Variant, dict As Object
Set dict = CreateObject("scripting.dictionary")
With Worksheets("sheet1")
For d = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
If Not dict.Exists(Application.Sum(.Rows(d))) Then
dict.Add Key:=Application.Sum(.Rows(d)), _
Item:=Array(.Cells(d, "A").Value2, _
.Cells(d, "B").Value2, _
.Cells(d, "C").Value2)
End If
Next d
For Each k In dict.Keys
.Cells(.Rows.Count, "E").End(xlUp).Resize(1, 3).Offset(1, 0) = dict.Item(k)
Next k
End With
End Sub
I have attached the input file format with sample data here.
Can someone help with the macro code to get the output data as mentioned below.
Input file for Macro :
Roll No Name Mark1 Mark2
1 Abc 10 35
20 25
30 40
2 def 20 10
15 5
25 2
30 3
The merged cells data needs to be obtained in separate rows along with marks data.
Output Data to be obtained :
Roll No Name Mark1 Mark2
1 Abc 10 35
1 Abc 20 25
1 Abc 30 40
2 def 20 10
2 def 15 5
2 def 25 2
2 def 30 3
Check this out,
Sub unMerge()
Dim i As Long, strA As String, strB As String
Range("A:B").unMerge
strA = Cells(2, 1)
strB = Cells(2, 2)
For i = 2 To Cells(Rows.Count, 4).End(xlUp).Row
If Cells(i, 1) = "" Then
Cells(i, 1) = strA
Cells(i, 2) = strB
Else
strA = Cells(i, 1)
strB = Cells(i, 2)
End If
Next i
End Sub
Easier to fill the blanks with a formula:
Dim r As Range
Set r = Range("A1").CurrentRegion
r.UnMerge
r.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
I would like to generate all possible vectors where minimum and maximum of each element is known and some set of elements can have only the same value.
For example I have an input like this:
rid Set MaxId
1 a 1
2 b 2
3 c 2
4 c 2
5 c 2
Set identifies elements which all should always have the same value, MaxId identifies maximum integer atribute can have, minimum is always 1. From this data, we can create the following 4 combinations (denoted c1 - c4):
rid Set c1 c2 c3 c4
1 a 1 1 1 1
2 b 1 1 2 2
3 c 1 2 1 2
4 c 1 2 1 2
5 c 1 2 1 2
How can I do this using VBA? In my real data I have 100 rows with 5 different sets, resulting in total 80 variables where max Id is ranging between 1 and 5.
The example above is complete, there is no additional input to be provided. Let's consider different example:
rid Set MaxId
1 a 2
2 b 1
3 c 3
4 c 3
5 c 3
This would result in 6 possible combinations (2 x 1 x 3). There is only one 3 as this number is part of what I call "a set", identified by same letter c. The possible combinations are:
rid Set c1 c2 c3 c4 c5 c6
1 a 1 2 1 1 2 2
2 b 1 1 1 1 1 1
3 c 1 1 2 3 2 3
4 c 1 1 2 3 2 3
5 c 1 1 2 3 2 3
If I understand it right, then I would call your "sets" dimensions and your combinations possible addresses in those dimensions. For example in two dimensions x and y where x is in length 2 and y is in length 3 there are 6 possible points(x,y) if x and y elements of N. In three dimensions x, y and z where x is in length 2, y is in length 3 and z is in length 2 there are 12 possible points(x,y,z) if x, y and z elements of N.
For going through all addresses in dimensions normally nested loops are used. So I would do this here also.
Sub Dimensions()
With ThisWorkbook.Worksheets(1)
'create a dictionary for up to 5 different dimensions named "a" to "e"
'and their max length values
'using dictionary because mapping key (dimension name) to value (max length value)
Set dDimensions = CreateObject("Scripting.Dictionary")
dDimensions.Add "a", 9999 '9999 is the stop value which shows that this Dimension is not used
dDimensions.Add "b", 9999
dDimensions.Add "c", 9999
dDimensions.Add "d", 9999
dDimensions.Add "e", 9999
'get the dimension definitions from A2:B[n]
r = 2
Do While .Cells(r, 1) <> ""
sDimension = .Cells(r, 1).Value
lMax = .Cells(r, 2).Value
If lMax > 0 And dDimensions.exists(sDimension) Then
'if inconsistent definitions for length of dimensions exists,
'for example "a" with max length 3 and "a" with max length 2,
'then take the lowest max length definition, in example "a" with 2
If dDimensions.Item(sDimension) > lMax Then dDimensions.Item(sDimension) = lMax
End If
r = r + 1
Loop
'calculate the count of possible combinations
lCount = 1
For Each sDimension In dDimensions
lMax = dDimensions.Item(sDimension)
If lMax < 9999 Then lCount = lCount * lMax
Next
'create a dictionary for the results
'up to 5 different Dimensions named "a" to "e"
'and their possible values in lCount possible combinations
Set dResults = CreateObject("Scripting.Dictionary")
Dim aPointAddresses() As Long
ReDim aPointAddresses(lCount - 1)
dResults.Add "a", aPointAddresses
dResults.Add "b", aPointAddresses
dResults.Add "c", aPointAddresses
dResults.Add "d", aPointAddresses
dResults.Add "e", aPointAddresses
'go through all possible addresses and fill the dResults
lCount = 0
For a = 1 To dDimensions.Item("a")
For b = 1 To dDimensions.Item("b")
For c = 1 To dDimensions.Item("c")
For d = 1 To dDimensions.Item("d")
For e = 1 To dDimensions.Item("e")
If dDimensions.Item("a") < 9999 Then
arr = dResults.Item("a")
arr(lCount) = a
dResults.Item("a") = arr
End If
If dDimensions.Item("b") < 9999 Then
arr = dResults.Item("b")
arr(lCount) = b
dResults.Item("b") = arr
End If
If dDimensions.Item("c") < 9999 Then
arr = dResults.Item("c")
arr(lCount) = c
dResults.Item("c") = arr
End If
If dDimensions.Item("d") < 9999 Then
arr = dResults.Item("d")
arr(lCount) = d
dResults.Item("d") = arr
End If
If dDimensions.Item("e") < 9999 Then
arr = dResults.Item("e")
arr(lCount) = e
dResults.Item("e") = arr
End If
lCount = lCount + 1
If dDimensions.Item("e") = 9999 Then Exit For
Next
If dDimensions.Item("d") = 9999 Then Exit For
Next
If dDimensions.Item("c") = 9999 Then Exit For
Next
If dDimensions.Item("b") = 9999 Then Exit For
Next
If dDimensions.Item("a") = 9999 Then Exit For
Next
'now dResults contains an array of possible point addresses for each used dimension
'key:="dimension", item:={p1Addr, p2Addr, p3Addr, ..., pNAddr}
'clear the result range
.Range("D:XFD").Clear
'print out the results in columns D:XFD
.Range("D1").Value = "p1"
.Range("D1").AutoFill Destination:=.Range("D1:XFD1")
r = 2
Do While .Cells(r, 1) <> ""
sDimension = .Cells(r, 1).Value
arr = dResults.Item(sDimension)
.Range(.Cells(r, 4), .Cells(r, 4 + UBound(arr))).Value = arr
r = r + 1
Loop
End With
End Sub
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.