I need to put the result of the sum at the end of the last column on different sheets (Not the same number of columns and number of rows)
I need to fix the last part of the code to let that happen.
this is the code (I marked in the code what does not work):
Sub Sum_Dynamic_Rng()
Dim ws As Worksheet
Dim LastCell As Range
Dim ColumnNumber As Long
Dim ColumnLetter As String
ColumnNumber = Range("S3").End(xlToLeft).Column
ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
For Each ws In ThisWorkbook.Worksheets
Set LastCell = ws.Range(ColumnLetter & 2).End(xlDown).Offset(1, 0)
**LastCell = WorksheetFunction.Sum(ws.Range(ws.Range(ColumnLetter & 2), ws.Range(ColumnLetter & 2).End(xlDown)))**
Next ws
End Sub
Your code works one with two bugs
You searched for "LastCell" in the first sheet only because it was before the FOR loop. The spreadsheets have different dimensions from what you wrote, so I moved the search to a loop so that there is a re-check for each iteration.
Another (in my opinion) problem was the reboot which added up the previous calculations.
for example.
2 + 2 = 4, 2 + 2 + 4 = 8, 2 + 2 + 4 + 8 = 16 e.t.c.
My code is:
Sub Sum_Dynamic_Rng()
Dim ws As Worksheet
Dim LastCell As String 'I changed from Range to String
Dim ColumnNumber As Long
Dim ColumnLetter As String
For Each ws In ThisWorkbook.Worksheets
LastColumnNumber = ws.Range("s3").End(xlToLeft).Column
LastColumnLetter = Split(Cells(1, LastColumnNumber).Address, "$")(1)
LastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
LastCell = LastColumnLetter & LastRow + 1 ' (+1) - last but not the first empty
ws.Range(LastCell) = WorksheetFunction.Sum(ws.Range(ws.Range(LastColumnLetter & 2), ws.Range(LastColumnLetter & LastRow)))
ws.Range(LastCell).Interior.ColorIndex = 43 ''I added for better visualization
Next ws
End Sub
If you are satisfied with the answer, give me a plus point from the answer and close the topic, unless you have any questions.
:)
IT'S OK I did some changes and now it's working!
Sub Sum_Dynamic_Rng()
Dim ws As Worksheet
Dim LastCell As String 'I changed from Range to String
Dim ColumnNumber As Long
Dim ColumnLetter As String
For Each ws In ThisWorkbook.Worksheets
LastColumnNumber = ws.Range("s3").End(xlToLeft).Column
LastColumnLetter = Split(Cells(1, LastColumnNumber).Address, "$")(1)
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ***''REPLACE TO A FROM G IN THIS LINE***
LastCell = LastColumnLetter & LastRow + 1 ' (+1) - last but not the first empty
ws.Range(LastCell) = WorksheetFunction.Sum(ws.Range(ws.Range(LastColumnLetter & 2), ws.Range(LastColumnLetter & LastRow)))
ws.Range(LastCell).Interior.ColorIndex = 43 ''I added for better visualization
Next ws
End Sub
Related
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 trying to create a macro that takes the data in column B from Sheet1 to Sheet2 if the names in column A Sheet1 corresponds to the names in column A in Sheet2. The first part of the code works fine, but the second part which is the "Do Until" loop is the problem. With the code I currently have, the loop runs through the outer loop and inner loop for the first name in Column A, but then it does not go through the outer loop for the rest of the names in Column A. The code is below:
Sub PullNames()
Dim A As Range
Dim B As Range
Dim C As Range
Dim A2 As Range
Dim B2 As Range
Dim C2 As Range
Dim LastA As Long
Dim LastB As Long
Dim LastC As Long
Dim LastA2 As Long
Dim CheckName As String
Dim CheckName2 As String
Dim count As Long
LastA = Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
LastB = Sheets("Sheet1").Cells(Rows.count, 2).End(xlUp).Row
LastC = Sheets("Sheet1").Cells(Rows.count, 3).End(xlUp).Row
count = 2
Set A = Sheets("Sheet1").Range("A2:A" & LastA)
Set B = Sheets("Sheet1").Range("B2:B" & LastB)
Set C = Sheets("Sheet1").Range("C2:c" & LastC)
Set A2 = Sheets("Sheet2").Range("A" & count)
Set B2 = Sheets("Sheet2").Range("B" & count)
Set C2 = Sheets("Sheet2").Range("C" & count)
Sheets("Sheet2").Activate
A2.Activate
A.Copy Destination:=A2
A2.RemoveDuplicates Columns:=1, Header:=xlNo
A2.Columns.AutoFit
Sheets("Sheet1").Activate
LastA2 = Sheets("Sheet2").Cells(Rows.count, 1).End(xlUp).Row
Do Until count > LastA
CheckName = Sheets("Sheet1").Range("A" & count)
Name = CheckName
'creates a loop for the macro to go through the names on Sheet2
If count < LastA2 Then
CheckName2 = A2
Name2 = CheckName2
If Name = Name2 Then
B2 = B.Value
End If
count2 = count2 + 1
End If
count = count + 1
Loop
End Sub
You only have one loop. The place where your comment starts "create a loop" isn't a loop, it's an If statement. Here's how you might rewrite your code if I understand the logic correctly.
Sub PullNames()
Dim A As Range
Dim B As Range
Dim C As Range
Dim A2 As Range
Dim B2 As Range
Dim C2 As Range
Dim LastA As Long
Dim LastB As Long
Dim LastC As Long
Dim LastA2 As Long
Dim CheckName As String
Dim CheckName2 As String
Dim count As Long, count2 As Long
Dim Name_ As String
Dim Name2 As String
LastA = Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
LastB = Sheets("Sheet1").Cells(Rows.count, 2).End(xlUp).Row
LastC = Sheets("Sheet1").Cells(Rows.count, 3).End(xlUp).Row
count = 2
Set A = Sheets("Sheet1").Range("A2:A" & LastA)
Set B = Sheets("Sheet1").Range("B2:B" & LastB)
Set C = Sheets("Sheet1").Range("C2:c" & LastC)
Set A2 = Sheets("Sheet2").Range("A" & count)
Set B2 = Sheets("Sheet2").Range("B" & count)
Set C2 = Sheets("Sheet2").Range("C" & count)
Sheets("Sheet2").Activate
A2.Activate
A.Copy Destination:=A2
A2.RemoveDuplicates Columns:=1, Header:=xlNo
A2.Columns.AutoFit
Sheets("Sheet1").Activate
LastA2 = Sheets("Sheet2").Cells(Rows.count, 1).End(xlUp).Row
Do Until count > LastA
CheckName = Sheets("Sheet1").Range("A" & count)
Name_ = CheckName
'creates a loop for the macro to go through the names on Sheet2
'If count < LastA2 Then
count2 = 2
Do While count2 <= LastA2
CheckName2 = Sheets("Sheet2").Range("A" & count2)
Name2 = CheckName2
If Name_ = Name2 Then
'B2 = B.Value
Sheets("Sheet2").Range("B" & count2).Value = Sheets("Sheet1").Range("B" & count).Value
End If
count2 = count2 + 1
Loop
'End If
count = count + 1
Loop
End Sub
If there are duplicates (that you removed), this code will pull the last value it encounters, which you may not want. If, for instance, B is a number, you may want to add those numbers together in column B.
Here's how I would have written the code.
Public Sub PullNames2()
Dim rCell As Range
Dim rFound As Range
Dim rNames As Range
'Define the range that contains the names
'copy that range to sheet2 and remove the dupes
Set rNames = Sheet1.Range("A2").CurrentRegion.Columns(1)
rNames.Copy Sheet2.Range("A2")
With Sheet2.Range("A2").CurrentRegion
.RemoveDuplicates 1, xlNo
.Columns.AutoFit
End With
'Loop through all the names
For Each rCell In rNames.Cells
'use the Find method to find the name on sheet2
Set rFound = Nothing
Set rFound = Sheet2.Columns(1).Find(rCell.Value, , xlValues, xlWhole)
'If you found the name, add the value in B to whatever is already there
If Not rFound Is Nothing Then
rFound.Offset(0, 1).Value = rFound.Offset(0, 1).Value + rCell.Offset(0, 1).Value
End If
Next rCell
End Sub
A couple of notes:
I use codenames of sheets. These are the names VBA knows and are not the tab names. You don't have to use them, it's just my preference.
CurrentRegion is good if you don't have any gaps. If it doesn't work for your data, you can set rNames however you like to define ranges. You'll just need to use the same methodology for sheet2.
You have to set rFound to Nothing every time because it will remember the last time it found something. That way you can check for Nothing - that's what rFound is if it can't find what it's looking for.
Always test code from the internet on a copy of your data. Particularly code that changes stuff.
I have code with a BIG weakness. If i run it more than once it deletes the required data because it's deleting the columns as required. The first execution formats a SAP report which runs prefectly. I don't know how to stop it deleting the columns if its run again. please can someone take a look and advise? Thanks
Sub Format_ZM27KG()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim X1 As Long
Dim LookUpTable1 As Variant
Dim LookUpValue1 As Long
Dim LastRow1 As Long
Dim vAnswer1 As String
Dim X2 As Long
Dim vAnswer2 As Long
Dim LastRow2 As Long
Dim vAnswer3 As Long
Set ws1 = ActiveWorkbook.Worksheets("Format KG")
Set ws2 = ActiveWorkbook.Worksheets("LookUp")
Application.ScreenUpdating = False
Dim A1 As Long
For A1 = 1 To 8 Step 1
ws1.Rows(1).EntireRow.Delete
Next A1
Dim LR3 As Long
Dim i2 As Long
With ws1
LR3 = .Range("C" & .Rows.Count).End(xlUp).Row
For i2 = LR3 To 2 Step -1
If Not IsNumeric(.Range("C" & i2).Value) Or .Range("C" & i2).Value = "" Then .Rows(i2).Delete
Next i2
End With
'Delete columns on tab format cases
ws1.Columns("A:B").EntireColumn.Delete
ws1.Columns("B:D").EntireColumn.Delete
ws1.Columns("C:M").EntireColumn.Delete
ws1.Columns("N").EntireColumn.Delete
ws1.Columns("C").EntireColumn.Delete
ws1.Cells(1, "N").Value = "Category"
LastRow1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
LookUpTable1 = ws2.Range("A1:C500")
For X1 = 2 To LastRow1
LookUpValue1 = Cells(X1, "A").Value
vAnswer1 = Application.WorksheetFunction.VLookup(LookUpValue1, LookUpTable1, 3, False)
ws1.Cells(X1, "N").Value = vAnswer1
Next X1
ws1.Columns("A:AL").AutoFit
ws1.Rows(1).HorizontalAlignment = xlCenter
ws1.Range("A1").Select
Application.ScreenUpdating = True
End Sub
If you don't want columns to be deleted you will need to add if-statements to check whether the columns actually need to be deleted.
You can do this by changing this from your code:
'Delete columns on tab format cases
ws1.Columns("A:B").EntireColumn.Delete
ws1.Columns("B:D").EntireColumn.Delete
ws1.Columns("C:M").EntireColumn.Delete
ws1.Columns("N").EntireColumn.Delete
ws1.Columns("C").EntireColumn.Delete
Replace that with the block below:
'Delete columns if the column header for column "N" is not "category".
If ws1.Cells(1, "N").Value <> "Category" then
ws1.Columns("A:B").EntireColumn.Delete
ws1.Columns("B:D").EntireColumn.Delete
ws1.Columns("C:M").EntireColumn.Delete
ws1.Columns("N").EntireColumn.Delete
ws1.Columns("C").EntireColumn.Delete
end if
I would like to insert separating columns into an Excel report to make the existing columns easier to view.
The report is created dynamically and I never know how many columns there will be; there could be 5, 10, 17, etc.
The section starts at F and goes to ival=Application.WorksheetFunction.CountIf(range("D2:D" & LastRow), "Other")
So if ival=10 then the columns are F G H I J K L M N O, and I need to insert columns between F&G, G&H, H&I, I&J, ... and N&O.
This may be a possibility for inserting columns: Workbooks("yourworkbook").Worksheets("theworksheet").Columns(i).Insert
But I'm not sure how to loop through ival.
Sub InsertColumns()
Dim iVal As Integer
Dim Rng As range
Dim LastRow As Long
Dim i As Integer
With Sheets("sheet1")
LastRow = .range("D" & .Rows.Count).End(xlUp).Row
End With
iVal = Application.WorksheetFunction.CountIf(range("D2:D" & LastRow), "Other")
For i = 7 To iVal - 1
Workbooks("yourworkbook").Worksheets("theworksheet").Columns(i+1).Insert
Next i
End Sub
The below code should work without needing to worry about ival:
Sub InsertSeparatorColumns()
Dim lastCol As Long
With Sheets("sheet1")
lastCol = Cells(2, .Columns.Count).End(xlToLeft).Column
For i = lastCol To 7 Step -1
.Columns(i).Insert
.Columns(i).ColumnWidth = 0.5
Next
End With
End Sub
Try this:
Sub InsertSeparatorColumns()
Dim ws as Worksheet
Dim firstCol As String
Dim lastRow As Long
Dim i As Long
Dim howManySeparators As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
firstCol = "F"
lastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
howManySeparators = Application.WorksheetFunction.CountIf _
(ws.range("D2:D" & LastRow), "Other")
For i = 1 To howManySeparators * 2 Step 2
ws.Range(firstCol & 1).Offset(, i).EntireColumn.Insert
Next i
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.