So new to coding completely. here is question :
How do I make a code that finds a multiple of a number within a set.
Ex. I have a set of number: I want to order the number beginning with the first number with every pair that is 14 a part. I was able to figure out how to do this (See code below) But now I want to do another code looking for multiples of 14 so.. It would look at x, and then find (x*14), (x*(2*14)), etc.. Any help would be appreciated
Column A Column B
459
452
426
485
425
Sub GetPairs()
Dim x, z As Single
Dim lastrow, pasterow As Single
Dim testMass, nomMass As Single
lastrow = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
pasterow = 2
For x = 2 To lastrow
nomMass = Cells(x, 2).Value
testMass = Cells(x, 2) + 14
o
r z = 2 To lastrow
If Cells(z, 2).Value = testMass Then
Cells(pasterow, 7).Value = nomMass
Cells(pasterow, 8).Value = Cells(z, 2).Value
pasterow = pasterow + 1
End If
Next z
Next x
End Sub
Actually, it should be that simple.
multiple = Cells(x*14, 2)
I think that should do what you want.
Yes That worked perfectly.
Here is the final code I came up with :
Sub GetPairs()
``Dim x As Single, z As Single
Dim lastRow, pasterow As Single
Dim testMass, nomMass As Single
`` Dim lastValue As Long
` Dim colCounter As Long
``Dim lookUpRange As Range
`lastRow = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
`lastValue = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Value
`Set lookUpRange = Worksheets(1).Range("B2:B" & lastRow)
``pasterow = 2
`For x = 2 To lastRow
nomMass = Cells(x, 2).Value ' base value
colCounter = 3
For z = Round((nomMass + 14), 0) To Round((lastValue + 14), 0) Step 14
If Found(lookUpRange, z) Then
'found
Worksheets(1).Cells(x, colCounter) = z
colCounter = colCounter + 1
End If
Next z
Next x
End Sub
Private Function Found(rng As Range, valueToFind) As Boolean
On Error GoTo errHandler
Dim v
v = WorksheetFunction.VLookup(valueToFind, rng, 1, 0)
Found = True
Related
I would like to ask how to SUM the values quickly, when they are separated 30 rows from each other?
I would like to sum 9 values and input the result in different column as per the code below:
Sub sum()
Range("EG12").Formula = "=Sum(C12,C282, C552, C822,C1092,C1362,C1632,C1902,C2172,C2442)"
Range("EG42").Formula = "=Sum(C42,C312,C582, C852,C1122,C1392,C1662,C1932,C2202,C2472)"
Range("EG72").Formula = "=Sum(C72,C342,C612, C882,C1152,C1422,C1692,C1962,C2232,C2502)"
Range("EG102").Formula = "=Sum(C102,C372,C642,C912,C1182,C1452,C1722,C1992,C2262,C2532)"
End Sub
Where as you may have notice every destination cell is located exactly 30 rows between each other (inner rows are empty or contains different values) likewise copied cells, that are located exactly 270 rows between each other (see the image attached).
I was trying to do formula like this:
Sub sum2()
Dim lastrow As Long, i As Integer, total As Double, finalsum As Double
lastrow = Range("C2442").End(xlUp).Row
For i = 30 To lastrow
total = total + WorksheetFunction.sum(Range("C12" & i & "EG12" & i))
Next
finalsum = total
End Sub
...but I've got "Method 2Range of object2_Global failed.
Does somebody have some idea about this?
Thanks & regards,
I didn t make it that pretty with the 170 sum but you should understand the point like this:
Sub test2()
Dim lastrow As Long, i As Long, finalsum As Long
lastrow = Range("C2442").End(xlUp).Row
finalsum = 0
For i = 12 To lastrow Step 30
Range("E" & i).Value = WorksheetFunction.Sum(Cells(i, 3).Value, Cells(i + 170, 3).Value, Cells(i + 2 * 170, 3).Value, Cells(i + 3 * 170, 3).Value, Cells(i + 4 * 170, 3).Value, Cells(i + 5 * 170, 3).Value, Cells(i + 6 * 170, 3).Value, Cells(i + 7 * 170, 3).Value, Cells(i + 8 * 170, 3).Value, Cells(i + 9 * 170, 3).Value)
finalsum = finalsum + Range("E" & i).Value
Next i
End Sub
Try it with loops and unions.
Option Explicit
Sub sum30by270()
Dim i As Long, j As Long, lr as long
Dim r1 As Range, r2 As Range
With Worksheets("sheet2")
lr = .cells(.rows.count, "C").end(xlup).row
Set r1 = .Cells(12, "C")
For i = 282 To lr Step 270
Set r1 = Union(r1, .Cells(i, "C"))
Next i
'Debug.Print r1.Address(0, 0)
Set r2 = .Cells(12, "EG")
For j = 42 To 102 Step 30
Set r2 = Union(r2, .Cells(j, "EG"))
Next j
'Debug.Print r2.Address(0, 0)
r2.Formula = "=sum(" & r1.Address(0, 0) & ")"
End With
End Sub
Few remarks:
lastrow = Range("C2442").End(xlUp).Row
is not the right usage, you might want to change it to:
'going from specified cell down until empty cell is met
lastrow = Range("C2442").End(xlDown).Row
or
'going from last cell in C column up, until first non-empty cell is met
lastrow = Range(Rows.Count, 3).End(xlUp).Row
Second issue, if you want to loop every 30 rows, you should do it like this (also remember about proper indentation of your code!):
For i = 12 To lastrow Step 30
total = total + WorksheetFunction.Sum(Range(Cells(i, 1), Cells(i, 5)))
Next
finalsum = total
"C12" & i & "EG12" & i - & operator is a string concatenation, not addition, this is why you might get unexpected result.
Well, thank you all guys for our contribution. I would like to add final working formula for this issue:
Sub sum_1to10()
Dim i As Long, j As Long, lr As Long
Dim r1 As Range, r2 As Range
With Worksheets("13")
lr = .Cells(.rows.Count, "C").End(xlUp).Row
Set r1 = .Cells(12, "C") 'First cell with data in my worksheet - [![enter image description here][1]][1] C12
For i = 12 To 2442 Step 270 ' From 1st cell with data to 10th cell in this order C2442
'When put "lr" instead 2442 the values will be calculated as per all worksheet data included (in my case it was down to 8377
Set r1 = Union(r1, .Cells(i, "C"))
Next i
Set r2 = .Cells(12, "Eh")
For j = 12 To 1086 Step 30 'First subsequent cell with data with 30 rows step e.g C42, C72, etc
' Value 1086 correspond to the last row in label with sum
Set r2 = Union(r2, .Cells(j, "EG"))
Next j
r2.Formula = "=sum(" & r1.Address(0, 0) & ")"
End With
End Sub
Hopefully I have understood it well.
I decided to modify this formula in order to divide my calculation on 3 separate parts. I am making these bulk calculation for every month, and I have divided it for 3 decades.
New to VBA if someone could help me what im doing wrong here.
Trying to run a loop such that it looks for a specific text, starts the loop then stops at a specific point.
The loops is such that I want it to copy some values below in my sheet hence a is 55.
Im facing the error Block IF without End If
Here is the code:
Private Sub CommandButton3_Click()
For y = 1 To 15 Step 5
Dim x As Double
Dim a As Double
x = 1
a = 55
If Cells(x, y).Value = "Text1" Then
Do Until Cells(x, y).Value = "Text2"
Cells(a, y) = Cells(x, y).Value
Cells(a, y + 1) = Cells(x, y + 1)
x = x + 1
a = a + 1
Loop
End Sub
Indenting is the way forward, you have a for statement with no next and an if with no End If:
Private Sub CommandButton3_Click()
For y = 1 To 15 Step 5
Dim x As Double
Dim a As Double
x = 1
a = 55
If Cells(x, y).Value = "Text1" Then
Do Until Cells(x, y).Value = "Text2"
Cells(a, y) = Cells(x, y).Value
Cells(a, y + 1) = Cells(x, y + 1)
x = x + 1
a = a + 1
Loop
End If
Next y
end sub
Besides the issues I mentioned in the comments to your post, if I understood you correctly, you want to loop on cells at Column A, find the first "Text1", then copy all the cells to row 55 and below, until you find "Text2". If that's the case, try the code below :
Private Sub CommandButton3_Click()
Dim x As Long, y As Long
Dim a As Long
Dim LastRow As Long
With Worksheets("Sheet1") '<-- modify "Sheet1" to your sheet's name
For y = 1 To 15 Step 5
x = 1 '<-- reset x and a (rows) inside the columns loop
a = 55 '<-- start pasting from row 55
LastRow = .Cells(.Rows.Count, y).End(xlUp).Row
While x <= LastRow '<-- loop until last row with data in Column y
If .Cells(x, y).Value Like "Text1" Then
Do Until .Cells(x, y).Value = "Text2"
.Cells(a, y).Value = .Cells(x, y).Value
.Cells(a, y + 1).Value = .Cells(x, y + 1).Value
x = x + 1
a = a + 1
Loop
End If
x = x + 1
Wend
Next y
End With
End Sub
I have a full dictionary. All the words (360 000) are in one column.
I'd like to have Column B with all words starting with "a", column C with all words starting with b...
I am trying to do a loop or something... but... It is just too long.
Any tips? Or did someone already do this vba macro?
Tks,
Stéphane.
If we start with:
Running this short macro:
Sub SeparateData()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
End Sub
will produce:
NOTE:
You may want to add some error capture logic to the NewCol calculation line.
EDIT#1:
This version may be slightly faster:
Sub SeparateDataFaster()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long, time1 As Date, time2 As Date
N = Cells(Rows.Count, 1).End(xlUp).Row
time1 = Now
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
time2 = Now
MsgBox time1 & vbCrLf & time2
End Sub
You can try something like this.
For 360k records its take about 20sec.
To create tests data i use this sub:
Sub FillTestData()
Dim t As Long
Dim lng As Integer
Dim text As String
'Start = Timer
For t = 1 To 360000
text = vbNullString
lng = 5 * Rnd + 10
For i = 1 To lng
Randomize
text = text & Chr(Int((26 * Rnd) + 65))
Next i
Cells(t, 1) = text
Next t
'Debug.Print Timer - Start
End Sub
And for separate:
Sub sep()
'Start = Timer
Dim ArrWords() As Variant
Dim Row_ As Long
LastRow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ArrWords = Range("A1:A" & LastRow) 'all data from column A to array
For i = 65 To 90 ' from A to Z
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) = i Then
Cells(Row_, i - 63) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
Next i
'other than a[A]-z[Z]
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) < 65 Or Asc(UCase(ArrWords(j, 1))) > 90 Then
Cells(Row_, 28) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
'Debug.Print Timer - Start
End Sub
You could try:
For i = 1 To Cells(Rows.count, 1).End(xlUp).Row
Range(UCase(Left$(Cells(i, 1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Offset(IIf(Range(UCase(Left$(Cells(i, _
1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Row = 1, 0, 1), 0).Value = Cells(i, 1).Text
Next i
Which is just building the destination address using the first letter of the word by doing the following:
Loop through each cell in column A
Get the first letter of that cell and convert it to upper case
Find the last cell in the column starting with that letter
Move over 1 column to the right
Go up until we hit the last row of data
If the last row isn't row 1, move down another row (next blank cell)
Give this cell the same value as the cell in column A that we're assessing
You can enter the following formula:
For letter A in B Column:
=IF(UPPER(LEFT(A1,1))="A",A1,"")
For letter B in C Column:
=IF(UPPER(LEFT(A1,1))="B",A1,"")
Repeat the same for letter C, D and so on..
I have a macro that runs 4 formulas.
Sub Kit()
Dim ws As Worksheet
Dim LastRow As Long
Dim i, n, x As Integer
Set ws = ActiveWorkbook.Sheets("Report KIT (2)")
ws.Select
LastRow = Sheets("Report KIT (2)").Range("A" & Sheets("Report KIT (2)").Rows.Count).End(xlUp).Row
For i = 3 To LastRow
On Error Resume Next
If Range("BR" & i) >= Range("AM" & i) Then
Range("BS" & i) = "C"
Else: Range("BS" & i) = "GA + C"
End If
Next i
For i = 3 To LastRow
On Error Resume Next
Range("BT" & i).Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-1]=""C"",(RC[-3]/SUMIFS(C[-3],C[-6],RC[-6]))*(VLOOKUP('Report KIT (2)'!RC[-6],GA_C!C[-71]:C[-68],4,0)),SUM((RC[-3]/SUMIFS(C[-3],C[-6],RC[-6]))*(VLOOKUP('Report KIT (2)'!RC[-6],GA_C!C[-71]:C[-68],4,0)),(RC[-3]/SUMIFS(C[-3],C[-6],RC[-6],C[-1],""GA + C""))*(VLOOKUP('Report KIT (2)'!RC[-6],GA_C!C[-71]:C[-69],3,0))))"
Next i
For i = 3 To LastRow
On Error Resume Next
Range("BU" & i).Select
ActiveCell.FormulaR1C1 = "=RC[-4]+RC[-1]"
Next i
For i = 3 To LastRow
On Error Resume Next
Range("BV" & i).Select
ActiveCell.FormulaR1C1 = "=(RC[-2]+RC[-5])*0.13"
Next i
End Sub
I would like to modify it in order to repeat the same calculation, but after each full circle of all 4 formulas to move starting columns: BS; BT; BU; BV in 4 cells forward (so on the next circle they become BW; BX; BY; BZ, then on the 3rd run CA; CB; CC; CD etc.) And i would like to loop it for 11 times. Can anyone help with it, please?
You can try the below. I have referenced the columns with numbers, using the cells property. After each formula loop the column increments by 1.
Also remember that if you declare variables like this Dim i, n, x As Integer it will only declare x as an integer, i and n will be declared as variants.
Option Explicit
Sub Kit()
Dim ws As Worksheet
Dim LastRow As Long
Dim i As Integer, n As Integer, x As Integer, j As Integer, mcol As Integer
Set ws = ActiveWorkbook.Sheets("Report KIT (2)")
ws.Select
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
mcol = 71
For j = 1 To 11
For i = 3 To LastRow
On Error Resume Next
If Cells(i, mcol - 1) >= Range("AM" & i) Then
Cells(i, mcol) = "C"
Else
Cells(i, mcol) = "GA + C"
End If
Next i
mcol = mcol + 1
For i = 3 To LastRow
On Error Resume Next
Cells(i, mcol) = "D" ''formula using mcol
Next i
mcol = mcol + 1
For i = 3 To LastRow
On Error Resume Next
Cells(i, mcol) = "E" ''formula using mcol
Next i
mcol = mcol + 1
For i = 3 To LastRow
On Error Resume Next
Cells(i, mcol) = "F" ''formula using mcol
Next i
mcol = mcol + 1
Next j
End Sub
You need 2 new loops and change the range method to cells method
For mainLoop = 1 To 11
For newLoop = 0 To 4
'demonstration of the change
'in EDIT added the (newLoop * 4) * mainLoop into the column increment
For i = 3 To LastRow
If Cells(i, 70 + (newLoop * 4) * mainLoop ) >= Cells(i, 39) Then 'change the right part of compare >= as needed
Cells(i, 71 + (newLoop * 4) * mainLoop ) = "C"
Else: Cells(i, 71 + (newLoop * 4)*mainLoop ) = "GA + C"
End If
Next i
'repeat similar change in all other loops
For i = 3 To LastRow
'...
Next i
For i = 3 To LastRow
'...
Next i
For i = 3 To LastRow
'...
Next i
Next newLoop
Next mainLoop
Edit 2
After correct comments from the author of the question...This should do the trick.
For mainLoop = 0 To 10
For newLoop = 0 To 3 'changed to 3
For i = 3 To LastRow
If Cells(i, 70 + newLoop * 4 + 16 * mainLoop) >= Cells(i, 39) Then 'change the right part of compare >= as needed
Cells(i, 71 + newLoop * 4 + 16 * mainLoop) = "C"
Else: Cells(i, 71 + newLoop * 4 + 16 * mainLoop) = "GA + C"
End If
Next i
'repeat similar change in all other loops
For i = 3 To LastRow
'...
Next i
'...
Next newLoop
Next mainLoop
I need a macro to exports combinations from a range of many sets of values .
The sets of exporting combs will be smaler than the data range sets .
For examble lets say that i need all 2 set of values combinations of a 3 set of values in a data range .
DATA____ EXPORT
A B C____ AB AC BC
B B A____ BB BA BA
-
All the values of the data will be in different cels each one but the combs values must be in one cell each time.
Also the exports must be in horizontial as the example .
This is a code that ifound on web little close for me , but i cannot edit this to use it .
enter code here
Sub comb()
Dim vElements As Variant, vresult As Variant
Dim lRow As Long, i As Long
vElements = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
Columns("C:Z").Clear
lRow = 1
For i = 1 To UBound(vElements)
ReDim vresult(1 To i)
Call CombinationsNP(vElements, i, vresult, lRow, 1, 1)
Next i
End Sub
Sub CombinationsNP(vElements As Variant, p As Long, vresult As Variant, lRow As Long,
iElement As Integer, iIndex As Integer)
Dim i As Long
For i = iElement To UBound(vElements)
vresult(iIndex) = vElements(i)
If iIndex = p Then
lRow = lRow + 1
Range("C" & lRow).Resize(, p) = vresult
Else
Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
End If
Next i
End Sub
Thank you very much and sorry for my english .
I wonder if it was more convenient to use a new Sheet/ Range with cell reference
((= Sheet1! $A1 & Sheet1! B1)) this is three lines then copy
Sub Sub export_01()
Dim aStart, aExport
Dim aRow As Integer
aRow = ActiveSheet.Range("A65536").End(xlUp).Row
aStart = 1
aExport = 5
For i = 1 To aRow
Cells(i, aExport).Value = Cells(i, aStart) & Cells(i, aStart + 1)
Cells(i, aExport + 1).Value = Cells(i, aStart) & Cells(i, aStart + 2)
Cells(i, aExport + 2).Value = Cells(i, aStart + 1) & Cells(i, aStart + 2)
Next i
End Sub()
This seems to me simply use a second for loop
dim aStartend = 1
For i = 1 To aRow
For ii = 0 To 5 ' starts whist 0 to 5 = 6 time
Cells(i, aExport+ii).Value = Cells(i, aStart) & Cells(i,aStartend + ii)
--
--
next ii
next i