I'm trying to perform a loop on my spreadsheet that works its way down the rows until it hits the last row in the datasheet.
I have a formula in cell P1 and I copy it into G1 and the loop works its way down infinitely to G200, G201, etc. How do I make it stop at the last row?
This is the code I have already tried.
Dim output As Worksheet
Dim Lastrow As Long
Dim i As Integer
i = 1
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set output = ThisWorkbook.Worksheets("Output")
output.Range("P1").Value = "=SUM(Q1,R1)"
Do Until Lastrow = True
output.Range("P1").Copy Destination:=output.Cells(i, 7)
i = i + 1
Loop
I currently have 21 rows of data (this is not static though) and it should loop essentially 21 times in this instance.
No loop needed:
Sub NU112()
Dim output As Worksheet
Set output = ThisWorkbook.Worksheets("Output")
Dim Lastrow As Long
Lastrow = output.Range("A" & output.Rows.Count).End(xlUp).Row
output.Range("G1:G" & Lastrow).Formula = "=SUM(Q1,R1)"
End Sub
For loops work better for looping through cells. I put everything in a with block so you don't need to constantly qualify ranges.
Dim output As Worksheet
Dim Lastrow As Long
Dim i As Integer
Set output = ThisWorkbook.Worksheets("Output")
with output
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
output.Range("P1").formula = "=SUM(Q1,R1)"
for i = 1 to lastrow
.Cells(i, 7).value = .cells(1, 16).value
next i
end with
Related
Would anyone will be able to help me with this script please?
As it stand, this current macro separate the data once the value/text have changes and insert new row but I just cannot work it out how to include the headers once the row have been inserted.
Sub Insert Row()
Dim ws As Worksheet
Dim lr As Long
Dim i As Long
Set ws = Worksheets("Sheet1") 'the sheet with the data
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'last row with data in Column A
For i = lr - 1 To 2 Step -1
If ws.Range("A" & i).Value <> ws.Range("A" & i + 1).Value Then ws.Range("A" & i + 1).EntireRow.Insert
Next i
End Sub
Thank you in advanced.
Duplicate Headers
A Quick Fix
Sub InsertHeaders()
Const FIRST_ROW As Long = 1
Const EMPTY_ROWS As Long = 1
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim r As Long
For r = LastRow To FIRST_ROW + 2 Step -1
With ws.Cells(r, "A")
If .Value <> .Offset(-1).Value Then
.EntireRow.Resize(EMPTY_ROWS + 1).Insert
ws.Rows(1).Copy ws.Rows(.Row - 1)
End If
End With
Next r
End Sub
Please ignore my comment, as I just realize that it will be a different result if in column A there is a cell with the same value.
Example Data :
Expected result after running the sub :
Sub test()
Dim rgHdr As Range: Dim rgData As Range: Dim cell As Range
Dim i As Integer: Dim arr: Dim ins As Integer:dim sh as worksheet
Set sh = Sheets("Sheet1") 'change if needed
ins = 3 'change if needed
With sh
.Range("A1").EntireRow.Resize(ins).Insert Shift:=xlDown
Set rgHdr = .Range("A1").EntireRow.Resize(1 + ins)
Set rgData = .Range("K" & 2 + ins, .Range("K" & Rows.Count).End(xlUp))
End With
Set arr = CreateObject("scripting.dictionary")
For Each cell In rgData: arr.Item(cell.Value) = 1: Next
For i = 1 To arr.Count - 1
rgHdr.Copy
sh.Cells(rgData.Find(arr.Keys()(i), _
after:=rgData.End(xlDown)).Row, 1).Insert Shift:=xlDown
Next
sh.Range("A1").EntireRow.Resize(ins).Delete
End Sub
sh = the sheets where the data is.
ins = skip how many blank rows.
The code use "insert copied cells" method, so it make three blank rows (the value of ins) before the header, then set the first three rows as rgHdr, set the rgData from K2 down to the last row with value.
arr = unique value in column K.
then it loop to each element in arr, get the first row occurence of the found cell which value is the looped element in arr, insert the copied rgHdr to that row.
Then finally it delete those three (ins value is 3) additional blank rows.
I am using an excel worksheet which consisted of two sheets. The First Source Sheet name is "Submitted" which looks like as under.
I want to search all the rows which are less than today() date from the column (F) circle red.
If rows are found, I want to transfer them to the destination sheet on the next blank row. In another case, if data are not found the sub should be closed without doing anything.
Once the data is transfer the particulars row/rows should be deleted from the source sheet.
The Destination sheet looks like this.
I am using the following code but it is not working as I want.
Sub MM1()
Dim Check As Range, r As Long, lastrow2 As Long, lastrow As Long
Application.ScreenUpdating = False
lastrow = Worksheets("Submitted").UsedRange.Rows.Count
lastrow2 = Worksheets("Agreements").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
For r = lastrow To 2 Step -1
If Range("F12" & r).Value <= Now() Then
Rows(r).Cut Destination:=Worksheets("Agreements").Range("A" & lastrow2 + 1)
lastrow2 = lastrow2 + 1
Else:
End If
Next r
Application.ScreenUpdating = True
End Sub
Please suggest me the best way and where I am doing wrong. Thanks
You shoud try to define your ranges/rows correctly, because otherwise it won't know, where it needs to pick the data up from, e.g. Rows(r).Cut should be Worksheets("Submitted").Rows(r).Cut. Also define your worksheets in the beginning to keep your code lean and give the variables names that anyone can follow.
Sub MMM1()
Dim loop1 As Long, lastrow2 As Long, lastrow As Long
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsSub As Worksheet, wsAgr As Worksheet
Set wsSub = wb.Worksheets("Submitted")
Set wsAgr = wb.Worksheets("Agreements")
Application.ScreenUpdating = False
lastrow = wsSub.Cells(wsSub.Rows.Count, 1).End(xlUp).Row
lastrow2 = wsAgr.Cells(wsAgr.Rows.Count, 2).End(xlUp).Row
If lastrow2 = 1 Then lastrow2 = 0
For loop1 = 12 To lastrow Step 1
If wsSub.Range("F" & loop1).Value <= Date Then
wsSub.Rows(loop1).Cut Destination:=wsAgr.Range("A" & lastrow2 + 1)
lastrow2 = lastrow2 + 1
End If
Next loop1
Application.ScreenUpdating = True
End Sub
Sub MS()
Data = Sheets("Tabelle1").Select
Rows("1:1").Select
Rows("11409:11409").Select
Dim bilder As Long
Dim n As Long
Dim d As Long
Dim t As Long
bilder = 64
n = 1
d = 0
t = 0
'Dim i As Long
'For i = 1 To lastrow
Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row).Select
Range("b1:b" & Cells(Rows.Count, 1).End(xlUp).Row).Select
'Range("a1").Select
'Range("b1").Select
Range("a1,b1").Select
Do While ActiveCell.Value <> ""
Radius = Sqr(Range("A1").Value * Range("A1").Value + Range("B1").Value * Range("B1").Value)
ActiveCell.Offset(1, 1).Select
Loop
End Sub
I'm not sure why you'd want to do it this way (given that it can be done with a simple formula in-cell), but looking at the remnants of code in your question we can see what you're trying to achieve. Here's how I'd do it:
Sub MS()
Dim sht As Worksheet, StartRow As Long, LastRow As Long, OutputColumn As Long
Dim SideA As Double, SideB As Double, SideC As Double
With Worksheets("Tabelle1")
'Set StartRow to the first row of your data ignoring headers
StartRow = 2
'Locate LastRow as last occupied cell in column A
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set OutputColumn to 3
OutputColumn = 3
'Start loop
For r = StartRow To LastRow
SideA = .Cells(r, 1).Value
SideB = .Cells(r, 2).Value
SideC = Sqr(SideA * SideA + SideB * SideB)
.Cells(r, OutputColumn).Value = SideC
Next
End With
End Sub
Output:
You do not need to select the range to work with it. You may want to see How to avoid using Select in Excel VBA
In your code you are not writing the output to any cell. Here are two ways that will help you achieve what you want.
NON VBA - WAY 1
Put the formula =SQRT(A1*A1+B1*B1) or =SQRT(A1^2+B1^2) in C1 and drag it down
VBA - WAY 2 (Without Looping)
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Set ws = Sheets("Tabelle1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C1:C" & lRow)
.Formula = "=SQRT(A1*A1+B1*B1)"
.Value = .Value
End With
End With
End Sub
VBA - WAY 3 (Without Looping) Slightly complicated way of doing this. Explanation can be seen HERE
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Set ws = Sheets("Tabelle1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C1:C" & lRow)
.Value = Evaluate("index(SQRT((A1:A" & lRow & _
")^2+(B1:B" & lRow & _
")^2),)")
End With
End With
End Sub
I am little bit confusion to write excel vba code. Please help me out.
Here is the my requirement
If two cells match’s in a row then need to give one name and next row match’s need to give another name dynamically through loop in excel vba
if cell-A = 1 and cell-B = 2 then frist name again if macthes next row second name
my code is
Sub fill_name()
Dim i As Integer
Dim nm As String
Dim j As Integer
Dim f_name() As String
For i = 1 To 4
ReDim f_name(2)
For j = 1 To 2
f_name(j) = Cells(j, 12).Value
If Cells(i, 1).Value = "1" And Cells(i, 3).Value = "2" Then
Cells(i, 2).Value = f_name(j)
End If
Next j
Next i
End Sub
You do not need VBA for this. You can achieve this via a formula
Put this formula in B2 and pull it down
=IF(AND(A2=1,C2=2),IF(COUNTIF($B$1:$B1,"Hi")=COUNTIF($B$1:$B1,"Hello"),"Hi","Hello"),"")
If you still want to use VBA then use the above formula like this
Sub fill_name()
Dim ws As Worksheet
Dim lRow As Long
Dim sFormula As String
sFormula = "=IF(AND(A2=1,C2=2),IF(COUNTIF(" & _
"$B$1:$B1,""Hi"")=COUNTIF($B$1:$B1,""Hello"")" & _
",""Hi"",""Hello""),"""")"
'~~> Change this as per your requirement
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("B2:B" & lRow)
.Formula = sFormula
.Value = .Value
End With
End With
End Sub
And if you do not want to use the formula but want to loop then use it like this
Sub fill_name()
Dim ws As Worksheet
Dim lRow As Long
Dim i As Long, j As Long
Dim MyAr(1 To 2) As String
MyAr(1) = "Hi"
MyAr(2) = "Hello"
j = 1
'~~> Change this as per your requirement
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
If .Range("A" & i).Value = 1 And .Range("C" & i).Value = 2 Then
.Range("B" & i).Value = MyAr(j)
If j = 1 Then j = 2 Else j = 1
End If
Next i
End With
End Sub
Can anyone help me. I want to count how many of the numbers are > 45 and put the result 3 rows below the last data cell. Lets give it a name - call it result. Then to the left of result I would like to put the words Number > 45. The amount of data rows will change, so when I run the macro on column D it will find the last data point and do the calculation. Some of the rows will be empty. Thanks for the help
Its should like that this
50
20
100
120
45
30
30
Return >45= 4
Sub enter()
Dim result As Integer
Dim firstrow As Integer
Dim lastwow As Integer
Firstrow = d2
Result = ‘ Value of count
Worksheets("sheet1").Range("c?").Value = "Total>45"
Range("d100000").End(xlUp).Select
End Sub
Try this
Sub Sample()
Dim result As Long, firstrow As Long, lastrow As Long
Dim ws As Worksheet
Dim rng As Range
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find Lastrow in Col D
lastrow = .Range("D" & .Rows.Count).End(xlUp).Row
'~~> Set First row
firstrow = 1
'~~> Set your range
Set rng = .Range("D" & firstrow & ":D" & lastrow)
'~~> Put relevant values
.Range("C" & lastrow + 3).Value = "Total>45"
.Range("D" & lastrow + 3).Value = _
Application.WorksheetFunction.CountIf(rng, ">45")
End With
End Sub
Screenshot
Here's one that will let you pass in any number, not just 45
Sub MakeCount(lGreaterThan As Long)
Dim lLast As Long
With Sheet1
lLast = .Cells(.Rows.Count, 4).End(xlUp).Row
.Cells(lLast + 3, 4).FormulaR1C1 = "=COUNTIF(R[-" & lLast + 1 & "]C:R[-3]C,"">""&RC[-1])"
.Cells(lLast + 3, 3).Value = lGreaterThan
.Cells(lLast + 3, 3).NumberFormat = """Number>""#"
End With
End Sub
can't you use a worksheet formula like
=COUNTIF(A2:A7,">45")
alternatively, in VBA as Mr Siddharth Rout suggests in his answer
is vba required?
if not, the function =COUNTIF(C:C,">45") will give you the answer you want.