I am new to using VBA within Excel and have come stuck while trying to create a loop to sum two consecutive numbers and output that to a merged cell to the side. The data looks as below:
Number - Sum
1 - 8
7 -
1 - 2
1 -
So I would like to loop throug the numbers in column 1 and add up the first 2 numbers (1 and 7 which would be cells A1 and A2) and return that value to the merged cell to the right of it which would be B1.
Below is what I have so far which does calculate correctly Cells A1 and A2 and put the value of 8 into Cell B1 but then just doesnt work at all. I have got a loop to work with calculating 2 values in seperate rows before but can't ge tmy head around how i can do that in this situation.
Sub Loop_Sum()
Set rng = Range("A1:A6")
For Each cell In rng
Cells(cell, 2) = Cells(cell, 1) + Cells(2, cell)
Next cell
End Sub
Appreciate any help / pointers.
Thanks.
You need to change to an incremented For .. Next and advance the increment step by 2.
Sub Loop_Sum()
dim i as long, rng as range
Set rng = Range("A1:A6")
For i= 1 to rng.cells.count step 2
rng(i).offset(0, 1) = rng(i) + rng(i + 1)
Next cell
End Sub
You want to use the Offset function:
Sub Loop_Sum()
Set rng = Range("A1:A6")
For Each cell In rng
If cell.Row Mod 2 = 0 Then 'Change 0 to 1 if it ends up on the worng row.
cell.Offset(, 2) = cell + cell.Offset(1)
End If
Next cell
End Sub
If you want a formula then put this in C2:
=If(mod(row(),2)=0,A2+A3,"")
And copy down.
Related
Please help me with this. I am trying to have an if condition where the condition is taken from the result of two added ranges then if the result is greater than 31 then the exceeding amount would add up to another cell.
Example:
IF (A1:A5 + B1:B5) > 31 Then
Value = C1:C5 + 5 *so the additional value for column C would be +5 if the value of A1 + B1 is 36.
End if
As of now this is what I got:
Dim cell As Range
For Each cell In Worksheets("Project Planner").Range("C6:C16")
If cell.Value > 31 Then
Worksheets("Database").Range("D6:D16").Value = cell.Value + 31
End If
Next
I don't know how to add two ranges and use the result as my condition. I am new to VBA, any help would be appreciated. TIA!
Depending on your your loop works, you will have to use different criteria for how you display the values you are adding.
Using a for loop, rather than a for each loop, I would be able to say that my If criteria has the sum of cells in the row i for columns 2 and 4 is greater than 31 by coding:
For i = 6 to 16
If (Cells(i, 2).Value + Cells(i, 4).Value) > 31 Then
'Function
End If
Next i
Given your for each loop, you can use offset() to help show this same use of columns 2 (B) and 4 (D), such as:
For Each cell in Worksheets("Project Planner").Range("C6:C16")
If (cell.Offset(0,-1).Value + cell.Offset(0,1).Value) > 31 Then
'Function
End If
Next cell
Dim rng1, rng2, rng3 As Range
Set rng1 = Worksheets("Project Planner").Range("C6:C16")
Set rng2 = Worksheets("Project Planner").Range("D6:D16")
Set rng3 = Worksheets("Project Planner").Range("E6:E16")
For i = 1 to rng1.rows.count
if rng1.cells(i,1) + rng2.cells(i,1) > 31 then
rng3.cells(i,1) = rng3.cells(i,1) + (rng1.cells(i,1)+rng2.cells(i,1)-31)
end if
next i
I have the following column (1):
1
15
150
1500000
06700
07290
07500
2
22
220
2200000
00900
This would need to become 2 columns
1
15
150
1500000 06700
1500000 07290
1500000 07500
2
22
220
2200000 00900
My initial idea:
Create the extra column.
Looping through the rows, register the cell and value in variables when a number with lenght of 7 digits is found.
Move the values under it to column B until the lenght of values is <> 5
Start from cell saved in variable and copy value from variable to column A until column A is no longer Empty
After the above proces, loop rows and delete where A is lenght 7 and B is empty.
As i am not familiar with VBA, before i plunge into, i would like to verify this above set of rules would do what i intend it to do, if it's technically feasable with VBA macro's and wether or not it could result to unexpected behaviour.
This code would have to run every month on a new large excel file.
Whether your 5 digit (c/w/ leading zeroes) numbers are true numbers with a cell formatting of 00000 or text-that-look-like-numbers with a Range.PrefixCharacter property, the Range.Text property should be able to determine their trimmed length from the displayed text.
The following code follows your logic steps with a few modifications; the most obvious one is that it walks from the bottom of column A to the top. This is to avoid skipping rows that have been deleted.
Sub bringOver()
Dim rw As Long, v As Long, vVAL5s As Variant, vREV5s As Variant
'put the cursor anywhere in here and start tapping F8
'it will help if you can also see the worksheet with your
'sample data
ReDim vVAL5s(0) 'preset some space for the first value
With Worksheets("Sheet1") '<~~ set this worksheet reference properly!
'ensure a blank column B
.Columns(2).Insert
'work from the bottom to the top when deleting rows
'or you risk skipping a row
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
'determine the length of the trimmed displayed length
'and act accordingly
Select Case Len(Trim(.Cells(rw, 1).Text))
Case Is < 5
'do nothing
Case 5
'it's one to be transferred; collect it
vVAL5s(UBound(vVAL5s)) = .Cells(rw, 1).Text
'make room for the next
ReDim Preserve vVAL5s(UBound(vVAL5s) + 1)
Case 7
'only process the transfer if there is something to transfer
If CBool(UBound(vVAL5s)) Then
'the array was built from the bottom to the top
'so reverse the order in the array
ReDim vREV5s(UBound(vVAL5s) - 1)
For v = UBound(vVAL5s) - 1 To LBound(vVAL5s) Step -1
vREV5s(UBound(vREV5s) - v) = vVAL5s(v)
Next v
'working With Cells is like selecting htem but without selecting them
'want to work With a group of cells tall enough for all the collected values
With .Cells(rw, 1).Resize(UBound(vREV5s) + 1, 1)
'move over to column B and put the values in
.Offset(0, 1) = Application.Transpose(vREV5s)
'make sure they show leading zeroes
.Offset(0, 1).NumberFormat = "[Color13]00000;[Color9]#"
'if there was more than 1 moved over, FillDown the 7-wide value
If CBool(UBound(vREV5s)) Then .FillDown
'delete the last row
.Cells(.Rows.Count + 1, 1).EntireRow.Delete
End With
'reset the array for the next first value
ReDim vVAL5s(0)
End If
Case Else
'do nothing
End Select
'move to the next row up and continue
Next rw
'covert the formatted numbers to text
Call makeText(.Columns(2))
End With
End Sub
Sub makeText(rng As Range)
Dim tCell As Range
For Each tCell In rng.SpecialCells(xlCellTypeConstants, xlNumbers)
tCell.Value = Format(tCell.Value2, "\'00000;#")
Next tCell
End Sub
Just before exiting the primary routine, the short helper sub is called using column B as a range of cells. This will loop through all of the numbers in column B and convert the numbers into text with leading zeroes.
As noted in the code comments, set yourself up so you can see the code sheet as well as a portion of your worksheet and start tapping F8 to step through the code. I've tried to add a form of running commentary with the notes left above many of the code lines.
After writing the logic keeping in mind Jeeped's input i ended up making it the following way:
Force convert the column A to definately be Text
Create the extra column.
Get the number of rows with data
Loop 1: If column A cell lenght is 5, move cell to column B
Loop 2: If column A cell lenght is 7, we copy the value to variable.
Loop 2: If column A cell lenght is 0, we paste variable to the cell
After the above proces, loop rows and delete where A is lenght 7 and B is empty. (reverse loop for performance)
All input on the below posted code is more than welcome. I'm open for every kind of possible optimization.
Sub FixCols()
'First trim the numbers (text) with 2 methods. VBA trim and Worksheet formula trim
Range("A:A").NumberFormat = "#"
Dim Cell As Range
For Each Cell In ActiveSheet.UsedRange.Columns("A").Cells
x = x + 1
Cell = Trim(Cell)
Cell.Value = WorksheetFunction.Trim(Cell.Value)
Next
'Now insert empty column as B
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Determine rows with values for loop
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Loops to move around the data
Dim i As Long
Dim CellValue As Long
For i = 1 To LastRow
'move items to column B
If Len(Range("A" & i).Value) = 5 Then
Range("A" & i).Select
Selection.Cut
Range("B" & i).Select
ActiveSheet.Paste
End If
Next i
For i = 1 To LastRow
'if the row is a reknr we copy the value
If Len(Range("A" & i).Value) = 7 Then
CellValue = Range("A" & i).Value
End If
'Paste the reknr to the rows with item
If Len(Range("A" & i).Value) = 0 Then
Range("A" & i).Value = CellValue
End If
Next i
'Reverse loop (performance) to check for rows to delete (reknr without item)
i = LastRow
Do
If Len(Range("A" & i).Value) = 7 And Len(Range("B" & i).Value) = 0 Then
Rows(i).Delete
End If
i = i - 1
Loop While Not i < 1
End Sub
I am new to VBA and I've been working on a VBA project that needs to find the empty cell and add all the cells above that empty cell and also place the sum on it. I tried finding the right code for it but no luck. Any suggestions will be greatly appreciated.
Here's the part of the data in the project:
Thank you!
Actually, your question is not clear. The logic of my code is
Looping all row between startRow and lastRowAnd find blank cell(#N/A).If found, adding values of all above cell from that cell and set total to that cell.But the adding is quarterly. And If continuous cells are found, set 0.
Means:If startRow = 1 and lastRow = 11, blank cell are 5, 10 and 11.
So, total value from row 5 cell is adding of above 4 cell(1+2+3+4) and
total value from row 10 cell is also adding of above 4 cell(6+7+8+9).And total value from row 11 cell is 0. Don't know logic to do.
I think that I give an right answer. I already tested the code. It perfectly work for me. If it is not for you, let me know. Here the code:
Public Sub findTotal()
Dim startRow, lastRow As Long
Dim row, innerStart As Long
With Sheets("Budget")
'Set start row
startRow = 1
innerStart = startRow
'last row must be last blank row for add all cell above from that
lastRow = 35
'Looping all row between startRow and lastRow
For row = startRow To lastRow Step 1
'Loop until blank
If .Range("N" & row).Text = "#N/A" Then
If row - startRow > 0 And row <> innerStart Then
'Set total of above cell to blank cell
.Range("N" & row) = WorksheetFunction.Sum(.Range("N" & row - 1, "N" & innerStart))
'Set next start row for adding next blank cell
innerStart = row + 1
Else
'Set 0 for continuous cells
.Range("N" & row) = 0
'Here, if you want to set above total, you can use as follow:
'.Range("N" & row) = .Range("N" & row - 1)
End If
End If
Next row
End With
End Sub
Sub UpdateCSAH()
Dim S As String
Dim R As Long
Dim RR As Long
Dim CC As Long
Dim i As Long
Dim j As Long
Dim csah() As String 'an array that stores the CSAH sites
ReDim csah(1 To 100, 1 To 7)
Dim Ran As Range
Dim Ran1 As Range
Set Ran = Worksheets("Current Sites").Range("A1").CurrentRegion 'Ran is the region that has values
RR = 1 'row number in csah
CC = 1 'column number in csah
'check each value in Ran to see if its Route section has "CSAH"
For Each cell In Ran
R = cell.row
S = CStr(Cells(R, 4).value)
If InStr(S, "CSAH") > 0 Then 'check if "CSAH" is in the Route section
If CC > 7 Then 'reset the column number and go to the next row when reach the end of the column
CC = 1
RR = RR + 1
End If
csah(RR, CC) = cell.value
CC = CC + 1
End If
Next cell
Worksheets("CSAH Sites").Select
Range("A2:G100").Select
Selection.ClearContents
'assign each array values to cells in sheet"CSAH Sites"
i = 1
j = 1
For i = 1 To UBound(csah, 1)
For j = 1 To UBound(csah, 2)
Cells(i + 1, j) = csah(i, j)
Next j
Next i
'format the CSAH Sites values
Set Ran1 = Worksheets("CSAH Sites").Range("A1").CurrentRegion
For Each cell In Ran1
If cell.row = 1 Then
With cell.Font
.Color = -11489280
End With
ElseIf cell.row Mod 2 = 0 Then
With cell.Interior
.Color = 10092441
End With
End If
Next cell
End Sub
I have an Excel worksheet named "Current Sites" that has some data. If the 4th column has the word "CSAH", I want to store the values of that row into an array and assign those values to cells in the worksheet named "CSAH Sites". My code sometimes works (the 1st time you click), and most of times it doesn't work or doesn't work properly.
Please help me out! Thanks A Bunch!!
It looks like you want to check every row of data in the "Current Sites" sheet and if column 4 includes the "CSAH" text, then write the first 7 columns of data for that entry to the "CSAH Sites" sheet and add some colour to the even-numbered rows.
To check every row of data, you can read down just one column and use either the Offset or the Cells method to see the values of neighbouring cells. In your code you were "touching" every cell and each time you were then looking at the value in column 4 and also checking to see if the code had gone past column 7. That slows things down a lot and makes the code hard to understand.
You can also assign the values from a range of cells directly to another range of cells without using variables or an array.
See if this does what you want:
Sub UpdateCSAH()
Dim currentSitesRange As Range
Dim thisSiteRange As Range
Dim outputCell As Range
Dim numRowsOfData As Long
Const NUM_COLUMNS_OF_DATA As Integer = 7
Set currentSitesRange = Worksheets("Current Sites").Range("A1")
numRowsOfData = currentSitesRange.CurrentRegion.Rows.Count
Set currentSitesRange = currentSitesRange.Resize(RowSize:=numRowsOfData) 'currentSitesRange is the region that has values
Worksheets("CSAH Sites").Range("A2:G100").ClearContents
Set outputCell = Worksheets("CSAH Sites").Range("A2")
For Each thisSiteRange In currentSitesRange.Cells
' Look for "CSAH" in the Route section (column D)
If InStr(1, thisSiteRange.Offset(ColumnOffset:=3).Value, "CSAH", vbTextCompare) > 0 Then
' Found "CSAH" so write NUM_COLUMNS_OF_DATA columns of data to CSAH Sites sheet
outputCell.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Value = thisSiteRange.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Value
' Format the even-numbered rows
If outputCell.Row Mod 2 = 0 Then
With outputCell.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Interior
.Color = 10092441
End With
End If
Set outputCell = outputCell.Offset(RowOffset:=1)
End If
Next thisSiteRange
End Sub
I need to copy data from one sheet to another so that after selecting 1st row it will skip some 5 rows to fetch another data.
My initial data looks like this:
Row|Col A
1|abc
2|def
3|ghi
4|jkl
5|mnp
6|oqr
7|stu
...
The code should result in output:
Row|Col A
1|abc
2|oqr
...
this will copy the first cell from sheet1 to sheet 2, and then every 5th one after that. e.g. 1,6,11,16 from sheet1 into 1,2,3,4 in sheet2
to change it to say 7 rows just change the multiplier on i to that value.
Cells(1 + i * 5, 1).
to change how many rows it copies change the following line
For i = 0 to 2
The code:
Sub copyData()
For i = 0 To 2
Sheets("Sheet2").Cells(1 + i, 1).Value = Sheets("Sheet1").Cells(1 + i * 5, 1).Value
Next i
End Sub
if you want it to start at the currently selected cell use the following version:
Sub copyData()
For i = 0 To 2
Sheets("Sheet2").Cells(1 + i, 1).Value = Sheets("Sheet1").Cells(ActiveCell.row + i * 5, ActiveCell.Column).Value
Next i
End Sub
How about:
Sub dural()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
s1.Range("A1").Copy s2.Range("A1")
s1.Range("A6:A" & N).Copy s2.Range("A2")
End Sub