I'm working on a project where I need to combine 6 keywords to the maximum number of combinations. After this is done, I have to transform these combinations to a form of binary.
example:
Word1 = 100000
Word2 = 010000
Word3 = 001000
Word4 = 000100
Word5 = 000010
Word6 = 000001
And a combination could be: (Word1 Word2 Word5) = 110010
My 6 keywords are in column A2:A7.
If this could be done in VBA, it would make my job a lot easier.
Acording to basic math, 6 entries would combine to 64 combinations. I don't need the "blank" combination, why it'll total 63 combinations.
I'm fairly new to coding and have only worked in VBA for a couple of weeks, so I'm hoping that there might be a specialist out there that could help me with this problem.
Update!
This is what I have written so far. It only combines the words once:
Sub combinations()
Dim i As Long, j As Long, k As Long, l As Long, n As Long, m As Long, lr As Long
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
For j = i + 1 To lr
For k = j + 1 To lr
For l = k + 1 To lr
For n = l + 1 To lr
For m = n + 1 To lr
.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0) = .Cells(i, 1).Value & " " & .Cells(j, 1).Value & " " & .Cells(k, 1).Value & " " & .Cells(l, 1).Value & " " & .Cells(n, 1).Value & " " & .Cells(m, 1).Value
Next m
Next n
Next l
Next k
Next j
Next i
End With
End Sub
Regards,
Emil
It would be easier to begin with the bitmap representation (BTW it would be best to avoid calling those "binary")
Dim a, b, c, d, e, f, i
i = 1
For a = 0 To 1
For b = 0 To 1
For c = 0 To 1
For d = 0 To 1
For e = 0 To 1
For f = 0 To 1
Cells(i, 1).Value = "'" & a & b & c & d & e & f
i = i + 1
Next f
Next e
Next d
Next c
Next b
Next a
Related
I am writing a script to print in a message box, the cell value and repetitive number counts from 1-5.
Currently, I have a for loop that counts the total number of rows I have in my spreadsheet. I am unsure of how to add another for loop (nested for loop) to call the program to add 1 to 5 to the first 5 rows, and restart at 1 to 5 again at the 6th row, and so on.
For example,
If values in cells A1 to A10 are "Apple" respectively, I want to concetenate numbers from 1 to 5 such that I get the results below:
A1 = "Apple1"
A2 = "Apple2"
A3 = "Apple3"
A4 = "Apple4"
A5 = "Apple5"
A6 = "Apple1" 'it starts from 1 again
A7 = "Apple2"
and so on
Below is my sample code:
Option Explicit
Sub appendCount()
Dim q, i, rowStart, rowEnd , rowNum, LR as Long
LR = Cells(Rows.Count, 1).End(xlUp).Row
rowNum = Range("A1:A" & LR).Count
For q = 1 To rowNum Step 1
If Not IsNull(Range("A" & q)) Then
For i = 1 to 5
MsgBox Range("A" & q).Value & i
Next i
End If
Next q
End Sub
Any help would be greatly appreciated!
I believe the following will do what you expect, it will look at the values on Column A and add the count to them on Column B:
Option Explicit
Sub appendCount()
Dim LR As Long, rownumber As Long, counter As Long
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
counter = 0
LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For rownumber = 1 To LR Step 1
If Not IsEmpty(ws.Range("A" & rownumber)) Then
counter = counter + 1
If counter = 6 Then counter = 1
ws.Range("B" & rownumber).Value =ws.Range("A" & rownumber).value & counter
End If
Next rownumber
End Sub
IsNull() on a cell will always return False. Replace IsNull by IsEmpty,
or use someCell <> "".
See https://stackoverflow.com/a/2009754/78522
Working with arrays will be faster. Also, mod will fail with large numbers so the below is written to handle large numbers. The point to start renumbering is also put into a constant to allow easy access for changing. Code overall is thus more flexible and resilient.
Option Explicit
Public Sub AddNumbering()
Dim arr(), i As Long, lastRow As Long, index As Long
Const RENUMBER_AT = 6
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Select Case lastRow
Case 1
ReDim arr(1, 1): arr(1, 1) = .Range("A1").Value
Case Else
arr = .Range("A1:A" & lastRow).Value
End Select
index = 1
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 1) <> vbNullString Then
If i - (CLng(i / RENUMBER_AT) * RENUMBER_AT) <> 0 And i <> 1 Then
index = index + 1
Else
index = 1
End If
arr(i, 1) = arr(i, 1) & CStr(index)
End If
Next
.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub
I understand your question is values in cells A1 to A10 are "Apple" respectively, you want to content Numbers from 1 to 5, then A6 to A10 content Numbers are also from 1 to 5.
This my test code, you can try it:
Option Explicit
Sub appendCount()
Dim q, i, cou, rowStart, rowEnd, rowNum, LR As Long
LR = Cells(Rows.count, 1).End(xlUp).Row
rowNum = Range("A1:A" & LR).count
cou = 1
For q = 1 To rowNum Step 1
If Not IsNull(Range("A" & q)) Then
For i = 1 To 5
MsgBox Range("A" & q).Value & cou
cou = cou + 1
If cou = 6 Then
cou = 1
End If
Next i
End If
Next q
End Sub
Your declaration is wrong, despite what you might expect these variables are NOT declared as Long but as Variant: q, i, rowStart, rowEnd , rowNum you must include the type for each variable separately.
This code should do the trick for you:
Sub appendCount()
Dim q As Long, LR As Long, rowNum As Long
LR = Cells(Rows.Count, 1).End(xlUp).Row
rowNum = Range("A1:A" & LR).Count
For q = 1 To rowNum Step 1
If Not Len(Range("A" & q).Value) = 0 Then
If q Mod 5 = 0 Then
MsgBox Range("A" & q).Value & 5
Else
MsgBox Range("A" & q).Value & (q Mod 5)
End If
End If
Next q
End Sub
Sub appendCount()
Dim q, c, i, rowStart, rowEnd, rowNum, LR As Long
LR = Cells(Rows.Count, 1).End(xlUp).Row
rowNum = Range("A1:A" & LR).Count
c = 1
For q = 1 To rowNum Step 1
If Not IsEmpty(Range("A" & q)) Then
If (c Mod 6) <> 0 Then
Range("B" & q).Value = Range("A" & q).Value & (c Mod 6)
Else
c = c + 1
Range("B" & q).Value = Range("A" & q).Value & (c Mod 6)
End If
End If
c = c + 1
Next q
End Sub
This would do it:
Sub Loops()
Dim i As Long, iMultiples As Long, iMultiple As Long
iMultiples = WorksheetFunction.Ceiling_Math(Cells(Rows.Count, 1).End(xlUp).Row, 5, 0) ' this rounds up to the nearest 5 (giving the number of multiples
For iMultiple = 1 To iMultiples
For i = 1 To 5
If Not IsNull(Range("A" & i).Value) Then Range("A" & i).Value = "Apple" & i 'This can be tweaked as needed
Next
Next
End Sub
First of all thanks for helping me.
I programmed a Sub and I always get an Overflow fault 6. Its in the line where it says While x<160. I cannot do more then 160. E.g. If I do 170 Ill get the fault. But I would like to do While x<1000
The goal is to sum up duration times. Eg. On 1/2/2017 we had 2 downtime for electrical reason, first was 2 minutes, second was 10 minutes.
This macro is making a summary for the 1/2/17 saying that we had 12min downtime because electrical reasons.
I don't do that in a professional way, but this would make my work so much easier! Its working. I only get this annoying Overflow fault if I want to write in large numbers.
Sub sumuptheduration()
'Then sum up all the duration times
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim x As Long
Dim summe As Variant
Dim valuecells As Range
a = 1
b = 2
c = 0
x = 1
Set valuecells = Worksheets(1).Range("P2")
Do While Worksheets(1).Range("C" & b).Value = Worksheets(1).Range("C" & b+a).Value And Worksheets(1).Range("J" & b).Value = Worksheets(1).Range("J" & b + a).Value
Set valuecells = Worksheets(1).Range("P" & b & ":P" & a + b)
a = a + 1
Loop
Worksheets(1).Range("S" & a + (b - 1)).Value = Application.WorksheetFunction.Sum(valuecells)
b = a + 2
c = a + 2
a = 1
Dim y As Integer
y = 0
While x < 160
Do While Worksheets(1).Range("C" & b).Value = Worksheets(1).Range("C" & b + a).Value And Worksheets(1).Range("J" & b).Value = Worksheets(1).Range("J" & b + a).Value
Set valuecells = Worksheets(1).Range("P" & b & ":P" & c + a)
a = a + 1
Loop
Worksheets(1).Range("S" & c + (a - 1)).Value = Application.WorksheetFunction.Sum(valuecells) 'Writes the Sum into the correct Cell (last one of combination)
'This if clause checks if there are "Single combinations" because single combinations do not go through the do while at the top
If Worksheets(1).Range("J" & b).Value <> Worksheets(1).Range("J" & b + a).Value And Worksheets(1).Range("J" & b).Value <> Worksheets(1).Range("J" & b + (a - 2)).Value Or Worksheets(1).Range("C" & b).Value <> Worksheets(1).Range("C" & b + a).Value And Worksheets(1).Range("C" & b).Value <> Worksheets(1).Range("C" & b + (a - 2)).Value Then
Worksheets(1).Range("S" & b).Value = Worksheets(1).Range("P" & b).Value
Else
End If
'Change the variables into correct way for the next passing of the do while clause
x = x + 1 'causes that do while is not just one time passes
b = c + a
c = c + a 'temporary variable to not forget the old b during the next passing of the do while
a = 1 'at the end of every passing a tells you how much times you needed to pass the do while, so you have to reset it every time
Wend
End Sub
here
Change the declarations as follows:
Dim a As Long
Dim b As Long
Dim c As Long
Do not declare these variables as Integer
Please have a look at the following given code. It does the work but the code gives the values including the duplicates. (see the output)
I couldn't figure out how to extract unique vales instead of duplicates.
S.No Values
1 99.501
2 99.441
3 99.346
4 99.683
5 99.683
6 99.941
7 99.326
8 99.315
9 99.326
10 99.564
11 99.565
12 99.513
13 99.396
14 99.676
15 99.083
16 99.083
17 98.886
18 99.129
19 99.129
20 99.73
My code:
Sub MaxMin()
Dim Rng As Range, Dn As Range, Lg As String
Dim n As Long, c As Long, nRay As Variant
Dim Sm As String, Sp As Variant, ac As Long
Dim col As Integer, R As Long, t
Set Rng = Range(Range("b2"), Range("b" & Rows.Count).End(xlUp))
For n = 1 To 5
Lg = Lg & IIf(Lg = "", Application.Large(Rng, n), "," _
& Application.Large(Rng, n))
Sm = Sm & IIf(Sm = "", Application.Small(Rng, n), "," _
& Application.Small(Rng, n))
Next n
Sp = Array(Split(Lg, ","), Split(Sm, ","))
ReDim Ray(1 To 11, 1 To 4)
Ray(1, 1) = "S.No"
Ray(1, 2) = "Max"
Ray(1, 3) = "S.No"
Ray(1, 4) = "Min"
For ac = 0 To 1
col = IIf(ac = 0, 1, 3)
c = 0
nRay = Range(Range("A2"), Range("b" & Rows.Count).End(xlUp)).Resize(, 2)
c = 1
For n = 0 To 4
For R = 1 To UBound(nRay, 1)
If Not IsEmpty(nRay(R, 2)) And nRay(R, 2) = Val(Sp(ac)(n)) Then
c = c + 1
Ray(c, col) = nRay(R, 1)
Ray(c, col + 1) = nRay(R, 2)
nRay(R, 2) = ""
Exit For
End If
Next R
Next n
Next ac
Range("F1").Resize(6, 4).Value = Ray
End Sub
Output:
S.No Max S.No Min
6 99.941 17 98.886
20 99.73 15 99.083
4 99.683 16 99.083
5 99.683 18 99.129
14 99.676 19 99.129
The modified code should not include "duplicate" only "unique" 5 max and 5 min values with their index positions.
You can use Dictionary Object to get such results which QHarr is referring to like below.
Public Sub GetMinMax()
Dim objDict As Object
Dim i As Long
Set objDict = CreateObject("Scripting.Dictionary")
'\\ Add uniques to list
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
If Not objDict.exists(Range("B" & i).Value) Then objDict.Add Range("B" & i).Value, Range("A" & i).Value
Next
'\\ Populate output columns
Range("F1").Resize(1, 4).Value = Array("S.No.", "Max", "S.No.", "Min")
For i = 1 To 5
Range("G" & i + 1).Value = Application.Large(objDict.keys, i)
Range("F" & i + 1).Value = objDict.Item(Range("G" & i + 1).Value)
Range("I" & i + 1).Value = Application.Small(objDict.keys, i)
Range("H" & i + 1).Value = objDict.Item(Range("I" & i + 1).Value)
Next
End Sub
Here is what trouble me:
For cells in column P, for example P3, if both P2 & B3 is not blank, but P3 is blank, then merge P2 with P3. And go on next cell in column P until respective cell in column B(for instance: B8) is blank, then stop.
B .... P
1 Monitor Tom
2 Mouse Ann
3 Keyboard
4 Sticker
5 Speaker John
6 Cable
7 Fan Rose
8
So for table above, I want to merge P2:P4 & P5:P6.
I've tried several time with my poor vba skill, but failed...
This code is what I've found in this website, and I've tried to edit it and see if this can solve my problem, but it doesn't work...
Sub Merge()
LR = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To LR
If ActiveSheet.Cells(i, 1).Value <> "" And ActiveSheet.Cells(i + 1, 1).Value = "" And ActiveSheet.Cells(i + 1, 2).Value <> "" Then
u = i + 1
Do While ActiveSheet.Cells(u, 1).Value = "" And ActiveSheet.Cells(u, 2) <> ""
u = u + 1
Loop
ActiveSheet.Range("A" & i & ":A" & (u - 1)).Select
With Selection
.Merge
.BorderAround Weight:=xlMedium
.WrapText = True
'.VerticalAlignment = x1VAlignTop
'.HorizontalAlignment = xlLeft
End With
Sheets(DataSheet).Range("B" & i & ":B" & (u - 1)).BorderAround Weight:=xlMedium
i = u + 1
End If
Next i
End Sub
Try this:
Dim i As Integer, a As String, b As String, c As Integer, d As Integer
i = 11
a = "B"
b = "P"
c = 0
d = 0
While Range(a & i) <> ""
If Range(b & i) = "" Then
If c = 0 And i > 1 Then
c = i - 1
d = 1
Else
d = d + 1
End If
Else
If c > 0 And d > 0 Then
Range(b & c & ":" & b & (c + d)).Merge
End If
c = 0
d = 0
End If
i = i + 1
Wend
If c > 0 And d > 0 Then
Range(b & c & ":" & b & (c + d)).Merge
End If
I'm trying to copy values from one small sheet "MD with ID" to A Larger sheet "D with ID" if 2 fields are identical (consider those two as keys that identify each record).
Here is my first try:
Sub CopyIDCells()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(e.Range("B" & j))
d = 2
Do Until IsEmpty(i.Range("A" & d))
If e.Range("C" & j).Value = i.Range("D" & d).Value Then
If e.Range("M" & j).Value = i.Range("J" & d).Value Then
e.Range("A" & j).Value = i.Range("B" & d).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Here is my second try:
Sub CopyIDCells2()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 1
j = 2
Do Until j = 20886
d = 2
Do Until d = 1742
If e.Cells(j, 3).Value = i.Cells(d, 4).Value Then
If e.Cells(j, 13).Value = i.Cells(d, 10).Value Then
e.Cells(j, 1).Value = i.Cells(d, 2).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Nothing changes in the excel sheet when this code runs, although it takes few minutes to run -_-".
.. sample was removed
So looking at your first CopyIdCells method, there is only one fix I would make to this - make variable d=2. This has headers at the top of your sample data and you need to start on row 2 just like the other sheet.
Sub CopyIDCells()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 2
j = 2
Do Until IsEmpty(e.Range("B" & j))
d = 2
Do Until IsEmpty(i.Range("A" & d))
If e.Range("C" & j).Value = i.Range("D" & d).Value Then
If e.Range("M" & j).Value = i.Range("J" & d).Value Then
e.Range("A" & j).Value = i.Range("B" & d).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Other than that your formulas look good, you just do not have any data that meets your requirements. Add this column to the bottom of "MD with ID" and you will see your code match.
mouse 10 08 11267 A/J M 823 1/11/2008 1 SC-807 LONG 10/10/2005
Since you are matching on "Case Number" AND "Other ID" there are no items in both sheets that meet this criteria. When you add the row above to "MD with ID", you will see the appropriate ID added to your second sheet on several rows.