I am trying to Sum every 3rd row in column "K", starting from K2 to the last cells used. Please note, the data or cells used in column "K" will vary.
I need a macro to sum the values in every 3rd row til the last row used and show the Total in "M1".
I attached a snapshot of some sample values and what I would like the end result to look like.
Short and slow (tested and in Excel it works only as an array formula):
[M1] = [SUM(IF(MOD(ROW(K:K),3)=1,K:K))]
or a bit longer by limiting the range:
[M1] = Evaluate(Replace("SUM(K2:K9*(MOD(ROW(2:9),3)=1))", 9, [K1].End(xlDown).Row))
Howdee Tom - This should do the trick for you.
Sub Sum_Every_Third()
Dim sht As Worksheet
Dim lastRow As Long, amount As Long
Set sht = Worksheets("Sheet1") 'Be sure to change to your correct sheet name
lastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
amount = 0
For i = 2 To lastRow
If Cells(i, 13).Offset(-1, 0).Row Mod 3 = 0 Then ' Make sure you change 13 to your column number
amount = amount + Cells(i, 13).Value
End If
Next i
MsgBox amount
End Sub
This sub should achieve your summing, see comments for details
Sub dosum()
' Get last row
Dim lastrow As Long
lastrow = ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Row
' Assign range object to data in column K
Dim myRange As Range
Set myRange = ActiveSheet.Range("K2:K" & lastrow)
' Sum every third item
Dim i As Long
Dim mySum As Double
mySum = 0
' Step through cells in range, 3 at a time
For i = 3 To myRange.Cells.Count Step 3
mySum = mySum + myRange.Cells(i).Value
Next I
' Put in cell
ActiveSheet.Range("M1").Value = mySum
End Sub
Related
I am using the macro below to keep cells only in a specified interval and remove the rest (i.e. keep the 1st, 5th, 10th, etc. point in a given column)
Dim i As Long
Dim lastRow As Long
lastRow = Application.ActiveSheet.UsedRange.Rows.Count
For i = 2 To lastRow Step 5
Range(Rows(i), Rows(i+8)).ClearContents
Next i
Currently, the macro deletes entire rows on the entire worksheet. I would like to modify the macro I can select the cell at the top of a single column I want to modify and run the macro only on that column.
For example, I have data in, say, A1:B350 and C1:E95 (both on the same sheet). I want to be able to run the macro and keep only a specified interval of cells in columns A-B without disturbing columns C-E. Likewise, I would like to run the same macro in column C without disturbing data in Column A. At this point, I am not sure how to modify this macro to meet this task. I'd greatly appreciate any help and guidance.
The following code will only affect the column you select, but I altered the step from 8 to 12 since otherwise all values were being cleared. Also, the usedRange function may not make sense since now only one column is the focus. Hopefully this code will get you started and you can adjust as needed.
Sub delColumnData()
Dim r As Range, col As Long, LastRow As Long, i As Long
Set r = Application.InputBox("select column", , , Type:=8)
col = r.Column
Set r = Cells(1, col)
LastRow = r.End(xlDown).row
For i = 2 To LastRow Step 12
Range(Cells(i, col), Cells(i + 8, col)).ClearContents
Next i
End Sub
To handle multiple columns:
Sub delColumnsData()
Dim r As Range, col As Long, LastRow As Long, i As Long, j As Long
Set r = Application.InputBox("select column(s)", , , Type:=8)
For j = 1 To r.columns.Count
col = r(j).Column
LastRow = r(j).End(xlDown).row
For i = 2 To LastRow Step 12
Range(cells(i, col), cells(i + 8, col)).ClearContents
Next i
Next j
End Sub
Another option
Option Explicit
Public Sub ClearColumnValues()
Dim i As Long, selectedCol As Long
selectedCol = Selection.Column 'in this case the Selection object can be convenient
With Application.ActiveSheet
For i = 1 To .UsedRange.Rows.Count Step 6
.Range(.Cells(i + 1, selectedCol), .Cells(i + 5, selectedCol)).ClearContents
Next
End With
End Sub
I am currently working on a macro and I had it working 100% like I wanted, but when I went to move the control group to a different sheet, I've started getting all sorts of problems. Here is the code:
Sub Duplicate_Count()
'Diclare Variables
Dim LastRow As Long
Dim value1 As String
Dim value2 As String
Dim counter As Long
Dim startRange As Long
Dim endRange As Long
Dim inColumn As String
Dim outColumn As String
Dim color As Long
counter = 0
Dim sht As Worksheet
Dim controlSht As Worksheet
Set sht = Worksheets("Sheet1")
Set controlSht = Worksheets("Duplicate Check")
'Find the last used row in column L
LastRow = sht.Cells(Rows.Count, "L").End(xlUp).Row
'set default ranges
startRange = 2
endRange = LastRow - 1
inColumn = "L"
outColumn = "N"
'check for user inputs
If controlSht.Cells(8, "B") <> "" Then
startRange = controlSht.Cells(8, "B")
End If
If controlSht.Cells(8, "C") <> "" Then
endRange = controlSht.Cells(8, "C")
End If
If controlSht.Cells(11, "C") <> "" Then
Column = controlSht.Cells(11, "C")
End If
If controlSht.Cells(14, "C") <> "" Then
Column = controlSht.Cells(14, "C")
End If
color = controlSht.Cells(17, "C").Interior.color
'Search down row for duplicates
Dim i As Long
For i = startRange To endRange
'Sets value1 and value2 to be compared
value1 = sht.Cells(i, inColumn).Value
value2 = sht.Cells(i + 1, inColumn).Value
'If values are not diferent then counter will not increment
counter = 1
Do While value1 = value2
sht.Cells(i, inColumn).Interior.color = color
sht.Cells(i + counter, inColumn).Interior.color = color
counter = counter + 1
value2 = sht.Cells(i + counter, inColumn).Value
Loop
'Ouput the number of duplicates on last duplicates row
If counter <> 1 Then
sht.Cells(i + counter - 1, outColumn) = counter
i = i + counter - 1
End If
Next i
End Sub
This is my first program so I apologize for all the mistakes. This code does exactly what I want except for finding the last row if there is no user input. It always says the last row is 1, when it should be 110460. I'm not sure if it's grabbing from the wrong sheet or if there is an error in my logic.
This should be easy to fix by just Activating the sheet first. I can't recall the exact syntax but since you tagged this macros just record a macro, then select a sheet and click on it somewhere. Then open up the macro it will say something like Sheets("sheet name".Activate. Or Sheets("sheet name").Select. Repeat that for each worksheet you want to run the macro on. To clarify, each time your macro finds the last row on 1 sheet, then you Activate or Select the next worksheet and find the last row again. Suppose this is being called in a loop through list of worksheet names.
I changed the "L" to an 11, and it all seems to work now. Why it wants it this way i have no clue, but it works.
I always do it like this.
Sub FindingLastRow()
'PURPOSE: Different ways to find the last row number of a range
'SOURCE: www.TheSpreadsheetGuru.com
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
'Ctrl + Shift + End
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Using UsedRange
sht.UsedRange 'Refresh UsedRange
LastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
'Using Table Range
LastRow = sht.ListObjects("Table1").Range.Rows.Count
'Using Named Range
LastRow = sht.Range("MyNamedRange").Rows.Count
'Ctrl + Shift + Down (Range should be first cell in data set)
LastRow = sht.Range("A1").CurrentRegion.Rows.Count
End Sub
https://www.thespreadsheetguru.com/blog/2014/7/7/5-different-ways-to-find-the-last-row-or-last-column-using-vba
First post here so bear with me. It's possible something similar to what I am going to ask has been posted but my technical illiteracy might have prevented me from finding it.
I have a column of data ~45,000 cells.
Within these cells lie descending data of individuals identified by an ID#, followed by anywhere from 1-8 additional cells with criteria relevant to the preceding ID#.
What I'm trying to do it convert this large column to a row for each of the ~5,500 IDs.
Here is an example of what I'm trying to achieve
I come from a beginner level SAS background and have only used Excel previously in a very brief manner, and have been trying to figure this out off and on for a week or two now. I've started transposing them manually but that is going to take forever and I hope there's an easier way.
My best guess would be, from what I've seen so far, that a VBA code could be written, but I don't know where to start with that. I'm also open to any other ideas on how to achieve the result I'm trying to get.
Thanks in advance!
Sub TransposeData()
Dim Data, TData
Dim x As Long, x1 As Long, y As Long
With Worksheets("Sheet1")
Data = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
ReDim TData(1 To UBound(Data, 1), 1 To 8)
For x = 1 To UBound(Data, 1)
'If the Data macthes the ID pattern (7 Digits) then
'increment the TData Row Counter
If Data(x, 1) Like "#######" Then
x1 = x1 + 1
y = 0
End If
'Increment the TData Column Counter
y = y + 1
TData(x1, y) = Data(x, 1)
Next
With Worksheets("Sheet2")
With .Range("A" & .Rows.Count).End(xlUp)
If .Value = "" Then 'If there is no data, start on row 1
.Resize(x1, 8).Value = TData 'Resize the range to fit the used elements in TData
Else ' Start on the next empty row
.Offset(1).Resize(x1, 8).Value = TData
End If
End With
End With
End Sub
If I correctly understand your problem the following code should solve it;
Sub ColToRow()
Dim inCol As Range
Set inCol = Application.InputBox(Prompt:="Please Select Range", Title:="Range Select", Type:=8) 'Get the input column as a range
Dim outCol As Range
Set outCol = inCol.Offset(0, 2) 'Set the output column as a range
Dim index As Long 'Current row
Dim cell As Range 'Current cell
Dim lastRow As Long 'The last row
Dim currRow As Long 'Current output row
Dim currCol As Long 'Current output column
lastRow = inCol.SpecialCells(xlCellTypeLastCell).Row
currRow = inCol.Row - 1
currCol = 0
For index = inCol.Row To lastRow
Set cell = ActiveSheet.Cells(index, inCol.Column) 'Set the cell range to the current cell
If Application.WorksheetFunction.IsNumber(cell) And Len(cell.Value) = 7 Then 'If numeric then we assume it is the ID, else we assume it is the
currRow = currRow + 1 'Advance to next output row
currCol = 0 'Reset column offset
cell.Copy Destination:=ActiveSheet.Cells(currRow, outCol.Column + currCol) 'Copy ID
ElseIf currRow > 0 Then 'Ensure we are within the row bounds and not at 0 or below
currCol = currCol + 1 'Advance the column
cell.Copy Destination:=ActiveSheet.Cells(currRow, outCol.Column + currCol) 'Copy Text Values until we get the next numeric value
End If
Next index 'Advance the row
End Sub
The code simply goes (in order) down the column and does the following;
- If the cell has a numeric value then we assume it is the ID and create a new row.
- If the cell has a text value we just add it to the next column in the current row, it'll continue to do this with however many string values until a new ID is reached.
Hope it helps.
-Regards
Mark
Another possible solution, based on ID being 7 digits numbers and all other numbers being not
Option Explicit
Sub main()
Dim area As Range
Dim iArea As Long
With ThisWorkbook.Worksheets("Transpose") '<--| reference relevant worksheet (change "Transpose" to your actual sheet name)
With .Range("A1", .Cells(.Rows.COUNT, 1).End(xlUp).Offset(1))
.Cells(.Rows.COUNT, 1).Value = 1111111 '<--| add a "dummy" ID to end data
.AutoFilter Field:=1, Criteria1:=">=1000000", Operator:=xlAnd, Criteria2:="<=9999999" '<--| filter its "JobCol_Master" named range on textbox ID
.Cells(.Rows.COUNT, 1).ClearContents '<--| remove "dummy" ID
With .SpecialCells(xlCellTypeVisible)
.Parent.AutoFilterMode = False
For iArea = 1 To .Areas.COUNT - 1
Set area = .Parent.Range(.Areas(iArea), .Areas(iArea + 1).Offset(-1))
.Parent.Cells(.Parent.Cells.Rows.COUNT, 3).End(xlUp).Offset(1).Resize(, area.Rows.COUNT).Value = Application.Transpose(area.Value)
Next iArea
End With
End With
End With
End Sub
I'm fairly new to VBA. I'm currently trying to find a faster way to copy and paste information by using Macros. I'm not sure how to code this.
I have two columns I want to use with a For Each loop.
I wanted to loop through each row of these two columns and use an If function. If the first row has a value in Column B (Column B cell <> "" Or Column B cell <> 0) then, select that row (i.e. Range("A1:B1")).
After the loop, I will copy whatever is selected and paste it to a specific row.
However, I want to keep adding to that selection as it loops through each row and only if it satisfies the If condition, so I'm able to copy it all once at the end. How do I go about combining this?
A B
1 Abc 1
2 Def 2
3 Geh 3
This is how you can expand current selection:
Sub macro1()
Set selectedCells = Cells(1, 2)
Set selectedCells = Application.Union(selectedCells, Cells(2, 3))
selectedCells.Select
End Sub
I'm sure you can manage the rest of your code by yourself, it's really easy. You already mentioned everything you need: For Each cell In Range("B1:B5") and If statement
Please try the below code
Sub test()
Application.ScreenUpdating = False
Dim rng As Range, one As Variant
Dim i As Integer
'Change the sheet and range name as yours
'Finding lastrow of destination column
i = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
' getting input from user
Set rng = Application.InputBox("Please select a range of cells!", "Please select a range", Selection.Address, , , , , 8)
For Each one In rng
If one.Value <> "" Or one.Value <> 0 Then
Range(one.Offset(0, -1), one).Copy
'Change the sheet and range name as yours
Sheets("Sheet2").Activate
Range("A" & i).Select
ActiveSheet.Paste
i = i + 1
End If
Next one
Application.ScreenUpdating = True
End Sub
The above macro will prompt you for the input range to be validate and copy to sheet2 in column A.
The below code will validate and copy paste the current selected range to sheet2 column A
Sub test()
Application.ScreenUpdating = False
Dim rng As Range, one As Variant
Dim i As Integer
'Chnage the sheet and range name as yours
'Finding lastrow of destination column
i = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
' getting input from user
Set rng = Selection
For Each one In rng
If one.Value <> "" Or one.Value <> 0 Then
Range(one.Offset(0, -1), one).Copy
'Chnage the sheet and range name as yours
Sheets("Sheet2").Activate
Range("A" & i).Select
ActiveSheet.Paste
i = i + 1
End If
Next one
Application.ScreenUpdating = True
End Sub
I think you're probably going about this the wrong way. Do you already know to where you would like to copy all the data in the end? It sounds like it, as you refer to copying it "to a specific row". If so, you'd be better off using your macro to copy the data from Columns A:B on the fly.
So, for example:
Sub CopyData()
Const SOURCE_COLUMN1 As Long = 1 ' A
Const SOURCE_COLUMN2 As Long = 2 ' B
Const TARGET_COLUMN1 As Long = 5 ' E
Const TARGET_COLUMN2 As Long = 6 ' F
Dim lngSourceRow As Long
Dim lngTargetRow As Long
With ThisWorkbook.Sheets("Sheet1")
lngSourceRow = 1
lngTargetRow = 0 ' Change this to the row above the one you want to copy to;
Do While .Cells(lngSourceRow, SOURCE_COLUMN1) <> ""
If .Cells(lngSourceRow, SOURCE_COLUMN2) <> "" Then
lngTargetRow = lngTargetRow + 1
.Cells(lngTargetRow, TARGET_COLUMN1) = .Cells(lngSourceRow, SOURCE_COLUMN1)
.Cells(lngTargetRow, TARGET_COLUMN2) = .Cells(lngSourceRow, SOURCE_COLUMN2)
End If
lngSourceRow = lngSourceRow + 1
Loop
End With
End Sub
This is my first time to code in VBA.
I have several worksheets in a file and they are in order by dates.
So what I am trying to do is to collect data sets in a worksheet if they have the same period of time.
date1 value1
date2 value2
date3 value3
Since they are in order I just compare the first date values and if they are different it moves on to the next worksheet. If they are the same then copy the value and do the same process until it reaches the last worksheet.
However it copies one worksheet fine but after that Excel freezes.
I would be appreciated if you find any errors or give me other suggestions to do it.
Following is my code:
Sub matchingStock()
Dim sh1 As Worksheet, sh2 As Worksheet
' create short references to sheets
' inside the Sheets() use either the tab number or name
Set sh1 = Sheets("combined")
Dim col As Long
'since first column is for Tbill it stock price should place from the third column
col = 3
Dim k As Long
'go through all the stock worksheets
For k = Sheets("WLT").Index To Sheets("ARNA").Index
Set sh2 = Sheets(k)
' Create iterators
Dim i As Long, j As Long
' Create last rows values for the columns you will be comparing
Dim lr1 As Long, lr2 As Long
' create a reference variable to the next available row
Dim nxtRow As Long
' Create ranges to easily reference data
Dim rng1 As Range, rng2 As Range
' Assign values to variables
lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
Application.ScreenUpdating = False
' Loop through column A on sheet1
For i = 2 To lr1
Set rng1 = sh1.Range("A" & i)
' Loop through column A on sheet1
For j = 2 To lr2
Set rng2 = sh2.Range("A" & j)
' compare the words in column a on sheet1 with the words in column on sheet2
'Dim date1 As Date
'Dim date2 As Date
'date1 = TimeValue(sh1.Range("A3"))
'date2 = TimeValue(sh2.Range("A3"))
sh1.Cells(1, col).Value = sh2.Range("A1").Value
' find next empty row
nxtRow = sh1.Cells(Rows.Count, col).End(xlUp).Row + 1
' copy the word in column A on sheet2 to the next available row in sheet1
' copy the value ( offset(0,1) Column B ) to the next available row in sheet1
sh1.Cells(nxtRow, col).Value = rng2.Offset(0, 6).Value
'when the date is different skip to the next worksheet
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
'sh3.Rows("1:1").Delete
Else
GoTo Skip
End If
Skip:
col = col + 1
Next k
End Sub
I cannot identify a specific error so this is a list of suggestions that may help you identify the error and may help improve your code.
Suggestion 1
Do you think the Else block of If-Then-Else-End-If is compulsory?
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
:
Else
GoTo Skip
End If
Skip:
is the same as:
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
:
End If
Suggestion 2
I do not like:
For k = Sheets("WLT").Index To Sheets("ARNA").Index
The value of property Index for a worksheet may not what you think it is. This may not give you the set or sequence of worksheets you expect. Do you want every worksheet except "Combined"? The following should be more reliable:
For k = 1 To Worksheets.Count
If Worksheets(k).Name <> sh1.Name Then
:
End If
Next
Suggestion 3
You use:
.Range("A" & Rows.Count)
.Range("A3")
.Cells(1, col).Value
.Cells(Rows.Count, col)
rng2.Offset(0, 6)
All these methods of identifying a cell or a range have their purposes. However, I find it confusing to use more than one at a time. I find .Cells(row, column) and .Range(.Cells(row1, column1), .Cells(row2, column2)) to be the most versatile and use them unless there is a powerful reason to use one of the other methods.
Suggestion 4
I cannot decypher what this code is attempting to achieve.
You say: "I have several worksheets in a file and they are in order by dates. So what I am trying to do is to collect data sets in a worksheet if they have the same period of time."
If you have set Worksheet("combined").Range("A3").Value to a particular date and you want to collect data from all those sheets with the same value in cell A3 then the outer For-Loop and the If give this effect. But if so, if does not matter how the worksheets are ordered. Also you start checking cell values from row 2 which suggests row 3 is a regular data row.
The outer loop is for each worksheet, the next loop is for each row in "combined" and the inner loop is for each row in the worksheet selected by the outer loop. The middle loop does not appear to do anything but set rng1 which is not used.
Perhaps you can add an explanation of what you are trying to achieve.
Suggestion 5
Are you trying to add an entire column of values from the source worksheets to "Combined". The macro below:
Identifies the next free row in column A of "Combined"
Identifies the last used row in column A of "Sheet2"
Assumes the first interesting row of "Sheet2" is 2.
Adds the entire used range of column A of "Sheet2" (complete with formatting) to the end of "Combined"'s column A in a single statement.
This may demonstrate a better way of achieving the effect you seek.
Sub Test()
Dim RngSrc As Range
Dim RngDest As Range
Dim RowCombNext As Long
Dim RowSrcFirst As Long
Dim RowSrcLast As Long
With Worksheets("Combined")
RowCombNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Set RngDest = .Cells(RowCombNext, "A")
End With
With Worksheets("Sheet2")
RowSrcFirst = 2
RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
Set RngSrc = .Range(.Cells(RowSrcFirst, "A"), .Cells(RowSrcLast, "A"))
End With
RngSrc.Copy Destination:=RngDest
End Sub