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
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
I have an Excel sheet where I have different numbers in range A1 to A10. I need to take the value from the cell and add that many rows under that cell.
Lets say A1 as 3 as value and macro should add 2 rows below A1.
I have tried using "Rows" function but I couldn't find a way out.
Please help.
This should get you going. Let me know if you need any further help.
Sub CellsValue()
Dim Colm As Integer
Dim lastrow As Long, deflastrow As Long
'Get the Position of the Required column which has the numbers that it has to shift towards
Colm = WorksheetFunction.Match("Cells Value", Sheets("Sheet1").Rows(1), 0)
'Get the lastrow of that column
lastrow = ActiveSheet.Cells(Rows.Count, Colm).End(xlUp).Row
deflastrow = Application.Sum(Range(Cells(1, Colm), Cells(lastrow, Colm)))
For i = 2 To deflastrow + lastrow
Range("A" & i + 1).Select
InsertRow = Range("A" & i).Value
If InsertRow > 0 Then
InsertRow = InsertRow - 1
End If
If InsertRow = 0 Then
Range("A" & i + 1).Select
Else
For j = 1 To InsertRow
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
Next
End Sub
I have made the change. Now it will work. Kindly accept the answer if it works for you.
Alternate solution:
Sub tgr()
Dim ws As Worksheet
Dim i As Long
Const sCol As String = "A"
Set ws = ActiveWorkbook.ActiveSheet
For i = ws.Cells(ws.Rows.Count, sCol).End(xlUp).Row - 1 To 1 Step -1
With ws.Cells(i, sCol)
If IsNumeric(.Value) Then
If .Value - 1 > 0 Then .Offset(1).Resize(.Value - 1).EntireRow.Insert xlShiftDown
End If
End With
Next i
End Sub
Dim i, max, num As Integer
i = 1
max = 10
Do While i < max
Range("A" & i).Select
num = Selection.Value
Dim x As Integer
x = 0
Do While x < num
i = i + 1
Range("A" & i).Select
Selection.EntireRow.Insert
max = max + 1
x = x + 1
Loop
i = i + 1
Loop
End Sub
I am doing automation on matching Data form row Data1 to Data 2,
I was done by looping statement but the problem is take much time, when number of row increase
For that reason i planed do by vlookup, In vlookup only return first occurrence cell but i need to find all match cell and highlighted matched row ,which i show in figure.
Working with cells directly reduces the code performance. Try to set Data1 and Data2 to arrays and work with arrays.
Something like this:
With ActiveSheet
arr = .Range(.[A2], .Cells(.Rows.Count, "A").End(xlUp)).Value
arr2 = .Range(.[D2], .Cells(.Rows.Count, "D").End(xlUp)).Value
For i& = 1 To UBound(arr)
For j& = 1 To UBound(arr2)
If arr(i, 1) = arr2(j) Then
...
End If
Next j
Next i
End With
Hope you are looking for this
Sub testvlookup()
Dim lastrow, lastrowdata, incre, i, j As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
lastrowdata = Range("D" & Rows.Count).End(xlUp).Row
incre = 6
For i = 2 To lastrow
For j = 2 To lastrowdata
If Range("A" & i).Value = Range("D" & j).Value Then
Range("D" & j, "G" & j).Interior.ColorIndex = incre
End If
Next j
incre = incre + 1
Next i
End Sub
I don't see the point why it should be to slow for many rows, it would be good to have more informations about that.
I would do it like the others, takes ~1 sec with 100000 comparisons.
Dim i As Integer
Dim b As Integer
i = 1
While i < 20000
Range("A1:A5").Copy Range(Cells(i, 4), Cells(i + 5, 4))
i = i + 5
Wend
MsgBox ("hi")
i = 1
While i < 7
b = 3
While b < 20000
If Cells(i, 1).Value = Cells(b, 4).Value Then
Cells(b, 4).Interior.ColorIndex = i
End If
b = b + 1
Wend
i = i + 1
Wend
End Sub
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
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