I am attempting to create a VBA code that will paste a formula to Variable Range of both columns and cells. I have the start of a code I thought I could modify, but I have been unsuccessful.
I have a sheet (see image) that has a variable range between A2 & ? I need to paste into the area C3 to the end of rows and columns a formula that will take the value in B and divide it by the number of columns. I thought I had a start but I am failing.
Please assist. "Start" Code Follows
Sub QtyByWks()
Dim M As Long, N As Long, i As Long, x As Long, j As Long
M = Sheet10.Cells(1, Columns.count).End(xlToLeft).Column
N = Sheet10.Cells(Rows.count, "A").End(xlUp).Row
j = 3
For x = 1 To M
For i = 1 To N
If Cells(i, "B").Value > 0 Then
Cells(j, "C").Value = Cells(i, "B").Value
j = j + 2
End If
Next i
Next x
End Sub
Also note, Both Rows and Columns are Variable via an additional VBA [Capture of Worksheet]
Thanks in advance for the assist
Hard to tell what sort of errors/issues you had with your code since you haven't provided much info. Either way, I'll take a stab at adjusting what you provided to do what I THINK you're trying to do:
Sub QtyByWks()
Dim M As Long, N As Long, i As Long, x As Long, j As Long
' Changed the formula to check row 2 instead of one, as per your screenshot.
M = Sheet1.Cells(2, Columns.count).End(xlToLeft).Column
N = Sheet1.Cells(Rows.count, "A").End(xlUp).Row
j = 3
'Replaced the x loop with a j loop that increments by 2.
For j = 3 To N Step 2
'Had the i loop start from 3 instead of 1
For i = 3 To M
If Cells(j, "B").Value > 0 Then
'Divided the "B" value by the number of columns M, which is what it sounds like you were going for in your description.
Cells(j, i).Value = Cells(j, "B").Value / (M - 2)
End If
Next i
Next j
End Sub
Obviously the code is working on the assumption that the Columns and Rows variables are returning expected values.
Related
In excel I would like to copy the date from one sheet to another one using macro in a way that it will copy everything until row 9, then it will skip row 10 and copy row 11 and 12, and then skip one again.
So it should not copy row 10,13,16,19, etc..
I have the following code
Dim i As Integer
i = 9
J = 1
K = 9
Do While i < 5000
If J = 3 Then
J = 0
Sheets("sheet1").Select
Rows(i).Select
Selection.Copy
Sheets("sheet2").Select
Cells(K, 1).Select
ActiveSheet.Paste
K = K + 1
End If
J = J + 1
i = i + 1
Loop
This code is copying everything till the 8th row and then every 3rd, can somebody help me how to modify that code?
Fastest way will be to Copy >> Paste the entire rows once, according to your criteria.
You can achieve it by merging all rows that needs to be copies to a Range object, in my code it's CopyRng, and you do that by using Application.Union.
Code
Option Explicit
Sub CopyCertailRows()
Dim i As Long
Dim CopyRng As Range
Application.ScreenUpdating = False
With Sheets("sheet1")
' first add the first 8 rows to the copied range
Set CopyRng = .Rows("1:8")
For i = 9 To 5000
If (i / 3) - Int(i / 3) <> 0 Then ' don't add to copied range the rows that divide by 3 without a remainder
Set CopyRng = Application.Union(CopyRng, .Rows(i))
End If
Next i
End With
' copy >> paste in 1- line
CopyRng.Copy Destination:=Sheets("sheet2").Range("A9")
Application.ScreenUpdating = True
End Sub
You could simplify this massively by using If i < 10 Or (i - 1) Mod 3 <> 0 Then... which will select the rows you're interested in. Like so:
Dim i As Integer, j As Integer
j = 0
Dim sourceSht As Worksheet
Dim destSht As Worksheet
Set sourceSht = Sheets("Sheet1")
Set destSht = Sheets("Sheet2")
For i = 1 To 5000
If i < 10 Or (i - 1) Mod 3 <> 0 Then
j = j + 1
sourceSht.Rows(i).Copy destSht.Rows(j)
End If
Next
Personally, I'd turn screen updating and calculations off before running this and enable them again after to reduce the time needed to perform the loop.
Also, as Michał suggests, unless your dataset happens to be exactly 5,000 rows, you might want to 'find' the last row of data before starting to further reduce the time needed.
All necessary comments in code:
'declare all variables, be consistent with lower/uppercases, use Long instead of Integeer (its stored as long anyway)
'use meaningful variable names
Dim i As Long, copyUntil As Long, currentRow As Long
copyUntil = 9
currentRow = 1
'copy all rows until we reach 9th row
For i = 1 To copyUntil
Sheets("sheet1").Rows(i).Copy
Sheets("sheet2").Rows(currentRow).Paste
currentRow = currentRow + 1
Next
'now we will takes steps by 3, on every loop we will copy i-th row and next one, third will be omitted
'we also use currentRow variable to avoid empty rows in sheet2
'also, 5000 seems wrong, I'd recommend to determine last row, until which we will loop
'last row is often determined like Cells(Rows.Count, 1).End(xlUp).Row
For i = copyUntil + 2 To 5000 Step 3
Sheets("sheet1").Rows(i).Copy
Sheets("sheet2").Rows(currentRow).Paste
currentRow = currentRow + 1
Sheets("sheet1").Rows(i + 1).Copy
Sheets("sheet2").Rows(currentRow).Paste
currentRow = currentRow + 1
Next
This code will only paste values. Let me know if any questions or if you really, really need the formatting I can tweak it.
Sub DoCopy()
'This code is pretty much specifit to your request/question, it will copy 1-9, skip 10, 13, 16....
'i for the loop, x for the row that will not be added, y to paste on the second sheet
Dim i, x, y As Long, divn As Integer
For i = 1 To 5000
If i < 10 Then
y = y + 1
Sheets("Sheet1").Rows(i).Copy
Sheets("Sheet2").Range("A" & y).PasteSpecial ''Paste values only
ElseIf i >= 10 Then
x = i - 10
If x Mod 3 <> 0 Then
y = y + 1
Sheets("Sheet1").Rows(i).Copy
Sheets("Sheet2").Range("A" & y).PasteSpecial ''Paste values only
Else
'Do nothing
End If
End If
Next i
End Sub
I have the following data. How can I code in VBA to execute the following?
E: I know it would be something with Looping, i.e: For Next.
But I am having troubles to loop the values that are not blank, in EACH column to the last column of the excel
Before:
After:
Run this VBA macro in your sheet,
Sub copyvalues()
Dim i As Long, j As Long, k As Long
k = 1
'Change the value to 200 to the last row number of your range
For i = 1 To 200
For j = 7 To 255
If Cells(i, j) <> "" Then
Range("F" & k).Value = Cells(i, j)
k = k + 1
End If
Next j
Next i
End Sub
I hope you can help me my VBA question. I would like to use a loop going down column A. Once a change is detected, I would like to insert a SUMIF formula in column C to total of column B if grouped the column A (Total offset to the right). A is already sorted. Kind of like Subtotal but without using the Subtotaling row.
A B C
1 2
1 6
1 3 11 =SUMIF(A:A,A3,B:B)
2 7
2 8 15 =SUMIF(A:A,A5,B:B)
3 8
3 6 14 =SUMIF(A:A,A7,B:B)
(without the added blank rows between 1 & 2 and 2 & 3 changes) I believe I am part of the way there with the following pieces of code pieces, but am having trouble getting to work together.
Sub SUMIF_Upon_Change()
Dim r As Long, mcol As String, i As Long
' find last used cell in Column A
r = Cells(Rows.Count, "A").End(xlUp).Row
' get value of last used cell in column A
mcol = Cells(r, 1).Value
' insert rows by looping from bottom
For i = r To 2 Step -1
If Cells(i, 1).Value <> mcol Then
Cells(n, 3).Formula = _
"=SUMIF(A:A,RC[-1],B:B)"
'AND / OR This added at the change row minus one row.
'Places formula in each adjacent cell (in column "D").
Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "=SUMIF(A:A,A3,BB)"
End If
Next i
End Sub
Any help will be much appreciated.
XLMatters, You pretty much have it. Your only major issue is that you seem to be mixing formula reference styles ("RC[-1]" and "A3"). You have to pick one or the other. Here is a working example of your code with a few minor modifications:
Sub SUMIF_Upon_Change()
Dim r As Long, mcol As String, i As Long
' find last used cell in Column A
r = Cells(Rows.Count, "A").End(xlUp).Row
' get value of last used cell in column A
mcol = Cells(r, 1).Value
For i = r To 2 Step -1
If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
Cells(i, 3).Formula = "=SUMIF(A:A,A" & i & ",B:B)"
End If
Next i
End Sub
If your heart is set on FormulaR1C1 style, here you go:
Sub SUMIF_Upon_ChangeRC()
Dim r As Long, mcol As String, i As Long
' find last used cell in Column A
r = Cells(Rows.Count, "A").End(xlUp).Row
' get value of last used cell in column A
mcol = Cells(r, 1).Value
For i = r To 2 Step -1
If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
Cells(i, 3).FormulaR1C1 = "=SUMIF(C1,RC1,C2)"
End If
Next i
End Sub
Should you have any other questions, just ask.
I'm trying to write a macro in excel that will identify the first value in a row (A2) and then search the rest of the row to clear any cell with a greater value (C2:DGA2). I'd like to set this up such that the program loops through every row in the column (A2:A400), and clears the corresponding values.
I tried using the following code, which I modified from another post:
Sub clear_cell()
Dim v
v = Excel.ThisWorkbook.Sheets("TOP LINE").Range("B2").Value
Dim Arr() As Variant
Arr = Sheet1.Range("C2:DGJ2")
Dim r, c As Long
For r = 1 To UBound(Arr, 1)
For c = 1 To UBound(Arr, 2)
If Arr(r, c) > v Then
Arr(r, c) = ""
End If
Next c
Next r
Sheet1.Range("C2:DGJ2") = Arr
End Sub
I modified it to fit my needs, but it only works for the first row. I need some help getting it to loop through every row in the first column.
Thank you for the help.
I'm trying to write a macro in excel that will identify the first value in a row (A2) and then search the rest of the row to clear any cell with a greater value (C2:DGA2).
From the above statement, I am assuming that all ranges are in the same sheet. Your code works for me if I make a few changes. See this
Sub clear_cell()
Dim i As Long, j As Long
Dim Arr
'~~> Set Range here
Arr = Sheet1.Range("A2:DGJ400").Value
For i = 1 To UBound(Arr, 1)
For j = 2 To UBound(Arr, 2)
If Arr(i, j) > Arr(i, 1) Then
Arr(i, j) = ""
End If
Next j
Next i
'~~> Write back to the sheet
Sheet1.Range("A2:DGJ400") = Arr
End Sub
give this a try:
Sub clear_cell()
x = 2
Do While x <= 400
Y = Range(Cells(x, 2), Cells(x, 2)).Value
If Y < 100 Then Range(Cells(x, 2), Cells(x, 2)).FormulaR1C1 = ""
x = x + 1
Loop
End Sub
The 2 is the column range, in this case B. Good Luck.
I have some VBA code that looks at the last new row for other instances of entries in Columns D and E of a row in the worksheet. When both of the column instances are found, the macro copies the data from Column F of the existing row to Column F of the new row.
However, the macro is restrictive as it ends after finding the first instance of this. I would like the macro to loop until all instances are found.
I figured the best way would be to convert the For loop into a For each loop but can't seem to make any code attempts work. Any pointers would be very helpful!
Sub test()
Dim N As Long
N = Cells(Rows.Count, "D").End(xlUp).Row
Dim i As Long
d = Cells(N, "D").Value
e = Cells(N, "E").Value
For i = N - 1 To 1 Step -1
dt = Cells(i, "D").Value
et = Cells(i, "E").Value
If d = dt And e = et Then
Cells(N, "F").Value = Cells(i, "F").Value
End If
Next i
End Sub
I see no reason to move to For Each in your case.
What you should do is read everything from your sheet into arrays at once, then loop through those arrays. It's much more efficient than looping through cells. Same goes for writing to sheet -- that's slow and inefficient. Just write the end result once, rather than repeatedly writing to the sheet.
Example:
Sub test()
Dim d, e, dt, et, ft, x
Dim i As Long
Dim N As Long
'Read everything from sheet into arrays
N = Cells(Rows.Count, "D").End(xlUp).Row
d = Cells(N, "D").Value
e = Cells(N, "E").Value
dt = Range("D1").Resize(N, 1).Value
et = Range("E1").Resize(N, 1).Value
ft = Range("F1").Resize(N, 1).Value
'Loop through arrays
For i = N - 1 To 1 Step -1
If d = dt(i, 1) And e = et(i, 1) Then
x = ft(i, 1)
End If
Next i
'Write result back to sheet
Cells(N, "F").Value = x
End Sub
Right, working from Jean-François Corbett's answer, which stores the contents in arrays before proceeding for efficiency, but adapting it to check for all duplicate rows in a progressive fashion, bottom-up. You get something like this:
Public Sub FillDuplicates()
Dim lastRow As Integer
Dim dColumn As Variant, eColumn As Variant, fColumn As Variant
Dim rowAltered() As Boolean
'Find the last row in Column D with content
lastRow = Cells(Rows.Count, "D").End(xlUp).Row
'Acquire data from columns: D, E & F in to arrays
dColumn = Range("D1").Resize(lastRow, 1).Value
eColumn = Range("E1").Resize(lastRow, 1).Value
fColumn = Range("F1").Resize(lastRow, 1).Value
ReDim rowAltered(1 To lastRow)
'Loop through all rows from bottom to top, using each D/E column value as a key
For cKeyRow = lastRow To 1 Step -1
'Ignore rows that have already been replaced
If Not rowAltered(cKeyRow) Then
'Loop through all rows above current key row looking for matches
For cSearchRow = cKeyRow To 1 Step -1
'If the row is a match and has not previously been changed, alter it
If Not rowAltered(cSearchRow) And dColumn(cKeyRow, 1) = dColumn(cSearchRow, 1) And eColumn(cKeyRow, 1) = eColumn(cSearchRow, 1) Then
fColumn(cSearchRow, 1) = fColumn(cKeyRow, 1)
rowAltered(cSearchRow) = True
End If
Next cSearchRow
End If
Next cKeyRow
'Store the amended F column back in the spreadsheet
Range("F1").Resize(lastRow, 1) = fColumn
End Sub
Note, all the work with rowAltered to determine rows that have been processed simply saves processing time. It would not be necessary, as the bottom-to-top action of the process would replace future key row values with lower duplicates as it went. Just it will do the replacements multiple times for each further duplicate up the page. The rowAltered check prevents this.
If you left the data in the spreadsheet, then you could use .Find() methods perhaps on the columns to locate duplicates, rather than the inner loop. But I doubt it would be more efficient.
I would say that
sequentially processing a list - especially with exit conditions - are better done with classical loops (Do/Loop, While, For/Next)
to use For Each ... In / Next you need to have a collection (like a range, list of sheets - anything ending on 's'), and keep in mind that it is not guaranteed that this list is processed top-down-left-right ... there is no predefined or chooseable sequence.
So according to the logic you describe I see no point changing For/Next to For Each ... In/Next.
You need to keep track of the new Row, so that each time you find a duplicate, you increase the new Row by 1. To expand on your code:
Sub test()
Dim N As Long
Dim CurRow As Long
N = Cells(Rows.Count, "D").End(xlUp).Row
CurRow = N
Dim i As Long
d = Cells(N, "D").Value
e = Cells(N, "E").Value
For i = N - 1 To 1 Step -1
dt = Cells(i, "D").Value
et = Cells(i, "E").Value
If d = dt And e = et Then
Cells(CurRow, "F").Value = Cells(i, "F").Value
CurRow = CurRow + 1
End If
Next i
End Sub