Ok this is what I tried with:
Sheets("ProDiver ored").Range("X" & i).Value = Sheets("ProDiver ored").Range("W2:W" + i).Value
But it doesn't work.
What I am trying to do is to make the macro take the W1:Wx and summarize these on the X column.
It should be looking like this in other words:
X1 = W1
X2 = W1 + W2
X3 = W1 + W2 + W3
X4 = W1 + W2 + W3 + W4
And so on.
Can you guys direct me on how to do this? I want it for a VBA Excel macro of course.
As Siddharth suggested (and slightly changed from the comment):
This will paste the formula from X1 down to the bottom of the data range:
Sub JustFormula()
With ThisWorkbook.Worksheets("Sheet1")
.Range(.Cells(1, 24), .Cells(Rows.Count, 23).End(xlUp).Offset(, 1)).Formula = "=SUM($W$1:$W1)"
End With
End Sub
A slight change to the procedure and you can have just the values instead:
Sub JustValues()
Dim MyRange As Range
With ThisWorkbook.Worksheets("Sheet1")
Set MyRange = .Range(.Cells(1, 24), .Cells(Rows.Count, 23).End(xlUp).Offset(, 1))
End With
MyRange.Formula = "=SUM($W$1:$W1)"
MyRange.Value = MyRange.Value
End Sub
If your workbook takes a while to calculate you may want to put a DoEvents before the .Value = .Value line.
Try
Sheets("ProDiver ored").Range("X" & i).Value = Application.Sum(Sheets("ProDiver ored").Range("W1:W" & i))
above assumes you do not need the formula to add values up just the result of the calculation
If you want to have all sub parts of the concatenation like in your example, you should have a loop: (untested!)
Dim cell As Object
Dim j As Integer
Dim newString As String
Set newString = ""
Set j = 0
For cell in Sheets("ProDiver ored").Range("W:W") 'entire column W
newString = newString + cell.Value
Range("X" & j).Value = newString
j = j + 1
Next
Try with this. I already tested it. It work well.
Public Sub summarizeValue()
Dim row As Integer
Dim summarize As Integer
Dim dataSheet As Worksheet
'Set start row
row = 1
'Getting data sheet
Set dataSheet = ThisWorkbook.Worksheets("sheetname")
'We need some break point, so I used "Do While" instead of "For" which is looping all cell.
'Loop column cells until blank
Do While dataSheet.Range("W" & row) <> ""
'If adding integer, use "+" sign
'If adding string, use "&" sign
summarize = summarize + dataSheet.Range("W" & row)
'Set summarize value into result cell
dataSheet.Range("X" & row) = summarize
'Increase row
row = row + 1
Loop
End Sub
Related
I am trying to make an auto scheduling program with an excel.
For example, each number is certain job assigned to the person given day.
1/2 1/3 1/4 1/5
Tom 1 2 2 ?
Justin 2 3 1 ?
Mary 3 3 ?
Sam 1 ?
Check O O X ? ## check is like =if(b2=c2,"O","X")
The things I want to make sure is every person is given a different job from yesterday.
My idea
while
randomly distribute jobs for 1/5
wend CheckCell = "O"
But I found that checking cell in the vba script doesn't work - the cell is not updated in each while loop.
Could you give me a little pointer for these kinds of program? Because I am new to vbaScript, any kinds of help would be appreciated.
Using VBA, I'm sure there are better ways to do this, but this will check the values from the penultimate column against values from last column and if they match it will write "O" to under the last column, else it will write "X":
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
counter = 0 'set counter
For i = 2 To LastRow 'loop through penultimate column and add values to array
If ws.Cells(i, LastCol - 1).Value <> "" Then
Values = Values & ws.Cells(i, LastCol - 1) & ","
End If
Next i
Values = Left(Values, Len(Values) - 1)
Values = Split(Values, ",") 'split values into array
For i = 2 To LastRow 'loop through last column and add values to array
If ws.Cells(i, LastCol).Value <> "" Then
ValuesCheck = ValuesCheck & ws.Cells(i, LastCol) & ","
End If
Next i
ValuesCheck = Left(ValuesCheck, Len(ValuesCheck) - 1)
ValuesCheck = Split(ValuesCheck, ",")
For y = LBound(Values) To UBound(Values) 'loop through both arrays to find all values match
For x = LBound(ValuesCheck) To UBound(ValuesCheck)
If Values(y) = ValuesCheck(x) Then counter = counter + 1
Next x
Next y
If counter = UBound(Values) + 1 Then 'if values match
ws.Cells(LastRow + 1, LastCol).Value = "O"
Else 'else write X
ws.Cells(LastRow + 1, LastCol).Value = "X"
End If
End Sub
just to clarify are you looking to implement the random number in the vba or the check.
To do the check the best way would be to set the area as a range and then check each using the cells(r,c) code, like below
Sub checker()
Dim rng As Range
Dim r As Integer, c As Integer
Set rng = Selection
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If rng.Cells(r, c) = rng.Cells(r, c + 1) Then
rng.Cells(r, c).Interior.Color = RGB(255, 0, 0)
End If
Next c
Next r
End Sub
this macro with check the text you have selected for the issue and change the cell red if it matches the value to the right.
To make it work for you change set rng = selection to your range and change the rng.Cells(r, c).Interior.Color = RGB(255, 0, 0) to the action you want
A sligthly different approach than the other answers.
Add this function:
Function PickJob(AvailableJobs As String, AvoidJob As String)
Dim MaxTries As Integer
Dim RandomJob As String
Dim Jobs() As String
Jobs = Split(AvailableJobs, ",")
MaxTries = 100
Do
MaxTries = MaxTries - 1
If MaxTries = 0 Then
MsgBox "Could find fitting job"
End
End If
RandomJob = Jobs(Int((1 + UBound(Jobs)) * Rnd()))
Loop Until RandomJob <> AvoidJob
PickJob = RandomJob
End Function
And put this formula in your sheet
=PickJob("1,2,3",D2)
where D2 points to is the previous job
I've got this spreadsheet in which I need to Sum up worked hours.
In Column 'I' I've got all worked hours which I sorted through weeknumbers in row 'E' with the following loop I found somewhere on Google (can't remember who wrote it but it works).
Dim i, itotalrows As Integer
Dim strRange As String
itotalrows = ActiveSheet.Range("E20000").End(xlUp).Offset(1, 0).Row
Do While i <= itotalrows
i = i + 1
strRange = "E" & i
strRange2 = "E" & i + 1
If Range(strRange).Text <> Range(strRange2).Text Then
Rows(i + 1).Insert
itotalrows = ActiveSheet.Range("E20000").End(xlUp).Offset(1, 0).Row
i = i + 1
End If
Loop
In the picture you can see one of the cells marked with "Total value of cells up
"
there's a blank every few rows with a cell on 'I' where the total value should go.
Sheet Picture:
Perhaps to sum the groups in column I, based on where the blanks are in column G
Sub x()
Dim r As Range
For Each r In Range("G:G").SpecialCells(xlCellTypeConstants).Areas
r.Cells(r.Count + 1).Offset(, 2).Value = WorksheetFunction.Sum(r.Offset(, 2))
Next r
End Sub
If you were to replace your code with the following, I believe it should do what you expect:
Sub foo()
Dim i, itotalrows As Integer
Dim strRange As String
itotalrows = ActiveSheet.Range("E20000").End(xlUp).Offset(1, 0).Row
Do While i <= itotalrows
i = i + 1
strRange = "E" & i
strRange2 = "E" & i + 1
If Range(strRange).Text <> Range(strRange2).Text Then
Rows(i + 1).Insert
Cells(i + 1, "I").FormulaR1C1 = "=SUMIF(C[-4],R[-1]C[-4],C)"
'when inserting a new row, simply add this formula to add up the values on column I
itotalrows = ActiveSheet.Range("E20000").End(xlUp).Offset(1, 0).Row
i = i + 1
End If
Loop
End Sub
Seeing as your code already does what you wanted (ie. add a new row when values on Column E differ) then adding the formula into that row will add up anything on Column I where the value of Column E is the same.
This is a general approach how to sum the cells in the blank cell.
If this is the input then the right ppicture should be the output:
.
Using this code:
Sub TestMe()
Dim myCell As Range
Dim currentSum As Double
For Each myCell In Worksheets(1).Range("A1:A14")
If myCell = vbNullString Then
myCell = currentSum
myCell.Interior.Color = vbRed
currentSum = 0
Else
currentSum = currentSum + myCell
End If
Next myCell
End Sub
The idea is simply to use a variable for the currentSum and to write it every time when the cell is empty. If it is not empty, increment it with the cell value
I am trying to create VBA code that copies and pastes data from Column B into the row directly beneath in Column A. I do not have great experience with VBA and so I am struggling to create such a code.
I would like to create a code that loops for an entire set of data in Columns A and B as shown in the attached picture.
So for example, B3 would get pasted into A4. B5 would get pasted into A6. And all the way down until the list was completed.
Thank you for any help!
The below code works quite good for your criteria.
rowNum = 3
Do While Trim(Range("A" & rowNum).Value) <> ""
Range("A" & (rowNum + 1)).Value = Range("B" & rowNum).Value
rowNum = rowNum + 2
Loop
Here is a simple example that will do what you ask.
For i = 2 To 10
If Range("A" & i) > "" And Range("A" & i + 1) = "" Then
Range("B" & i).Cut
Range("A" & i + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
End If
Next
Depending on what your data looks like, you will probably want to setup something more dynamic for the value of 'i'.
Use LastRowIndex from https://stackoverflow.com/a/71296/42346 to find the final row then iterate over the rows in column 2 placing the value in column 1 one row below the current row.
Sub iterate()
Dim r As Long
Dim c As Long
Dim endrow As Long
c = 2
endrow = LastRowIndex(ActiveSheet, c)
For r = 2 To endrow Step 1
If ActiveSheet.Cells(r, c).Value <> "" Then
ActiveSheet.Cells(r + 1, c - 1).Value = ActiveSheet.Cells(r, c).Value
End If
Next r
End Sub
Function LastRowIndex(ByVal w As Worksheet, ByVal col As Variant) As Long
Dim r As Range
Set r = Application.Intersect(w.UsedRange, w.Columns(col))
If Not r Is Nothing Then
Set r = r.Cells(r.Cells.Count)
If IsEmpty(r.Value) Then
LastRowIndex = r.End(xlUp).Row
Else
LastRowIndex = r.Row
End If
End If
End Function
I am looping through each cell in a column and performing split operation on the text(delimited by ,) for each cell. I have the result in an array.And I am placing it in a range of cells.When ever next cell value is fetched and split operation is carried , new value overwrites the previous result. How can i find the next empty cell and place the array content with out overwriting.
Range("A1:A" & UBound(x) + 1) = WorksheetFunction.Transpose(x)
I have texts separated by ,
example A,B,C,D in column E2
B,M,C... in E3 and so on till 36000(value may increase)
Dim txt As String
Dim x As Variant
Dim i As Long
Dim lrow As Double
lrow = Sheet1.UsedRange.Rows.Count
For j = 1 To lrow
txt = Sheet1.Range("m2").Offset(j - 1, 0)
x = Split(txt, ",")
For i = 0 To UBound(x)
'Debug.Print x(i)
Range("A1:A" & UBound(x) + 1) = WorksheetFunction.Transpose(x) 'How can i change this line to find next empty cell and palce the result in it
Next i
Next j
The above code will loop through each row and split the text. But every time the result is overwritten. How can i find next empty cell and place the result in it?
Please try this, This will work for M2=abc,BCD,Xyz,pdt. If M3=zse,ssd,vbd will come it will over write the value A1 to A(j) Value. So update it accordingly.
Dim i As Integer
Dim M2 As String
Dim spltStore As Variant
Public Sub page_load()
M2="abc,BCD,Xyz,pdt"
spltStore = Split(M2, ",")
j = 1
For i = 0 To UBound(spltStore)
Sheet1.Range("A" & j).Value = spltStore(i)
Debug.Print spltStore(i)
j = j + 1
Next i
End Sub
Hope this will work for you.
Try this:
j=1
i=1
Do While IsEmpty(Worksheets("test").Cells(j, i)) = False
'<do your stuff>
j = j + 1
Loop
j and i are cell coordinates. This loop will go through all the non-empty cells and stop on an empty one.
I have 3 issues with the following piece of code:
Intention of code: I have a table of data, 4 columns (F,G, H and I) wide and X rows long (X is typically between 5 and 400). I have a list of dates in column M, typically no more than 8 dates. Column H of table, contains dates as well. I want to find the dates that are in both columns (H and M) and whenever they appear, go to the same row in column I and set its value to zero, and the one after it (so if a match was in H100, then I100 and I101 would be zeroed).
issues with code: edited 1) as per feedback.
1) I have, using an if formula (=if(H100=M12,1,0), verified that there is one match, as how the spreadsheet sees it. The macro does not find this match, despite confirmation from the if formula. Cells I100 and I101 have nonzero values, when they should be zeroed.
2) the code runs, but takes about 3 minutes to go through 3 sheets of 180 rows of data. What can be done to make it run faster and more efficiently? It could have up to 30 sheets of data, and 400 rows (extreme example but possible, in this instance im happy to let it run a bit).
3) Assuming my data table before the macro is run, is 100 rows long, starting in row 12, after the macro, column I has nonzero values for 111 rows, and zeroes for the next 389. Is there a way I can prevent it from filling down zeroes, and leaving it blank?
I am using a correlate function afterwards on column I and there huge agreement of 0's with 0's is distorting this significantly. Thanks in advance,
Sub DeleteCells()
Dim ws As Worksheet
Dim cell As Range, search_cell As Range
Dim i As Long
Dim h As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then
For Each cell In ws.Range("H12:H500")
On Error Resume Next
h = ws.Range("G" & Rows.Count).End(xlUp).Row
i = ws.Range("L" & Rows.Count).End(xlUp).Row
Set search_cell = ws.Range("M12:M" & h).Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)
On Error GoTo 0
If Not search_cell Is Nothing Then
ws.Range("I" & cell.Row).Value = 0
ws.Range("I" & cell.Row + 1).Value = 0
Set search_cell = Nothing
End If
Next cell
End If
Next ws
Application.ScreenUpdating = True
Set ws = Nothing: Set cell = Nothing: Set search_cell = Nothing
End Sub
EDIT: TESTED CODE, will work for 0, 1 row of data in H/M column starting from row 12?
EDIT: Updated the cell to handle case with 1 line of data, untested :|
I will give my solution first, this one should be much faster because it read the cells into memory first
Please comment if it doesn't work or you have further question
Sub DeleteCells()
Dim ws As Worksheet
Dim i As Long
Dim h As Long
Dim MColumn As Variant ' for convinence
Dim HColumn As Variant
Dim IColumn As Variant
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then 'matching the target sheet
' matching the rows where column M's date matches column H's date
'starting row num is 12
With ws ' for simplifying the code
h = .Range("H" & .Rows.count).End(xlUp).Row
If h = 12 Then ' CASE for 1 row only
If Range("H12").Value = Range("M12").Value Then
Range("I12:I13").Value = ""
End If
ElseIf h < 12 Then
' do nothing
Else
ReDim HColumn(1 To h - 11, 1 To 1)
ReDim MColumn(1 To h - 11, 1 To 1)
ReDim IColumn(1 To h - 10, 1 To 1)
' copying the data from worksheet into 2D arrays
HColumn = .Range("H12:H" & h).Value
MColumn = .Range("M12:M" & h).Value
IColumn = .Range("I12:I" & h + 1).Value
For i = LBound(HColumn, 1) To UBound(HColumn, 1)
If Not IsEmpty(HColumn(i, 1)) And Not IsEmpty(MColumn(i, 1)) Then
If HColumn(i, 1) = MColumn(i, 1) Then
IColumn(i, 1) = ""
IColumn(i + 1, 1) = ""
End If
End If
Next i
'assigning back to worksheet cells
.Range("H12:H" & h).Value = HColumn
.Range("M12:M" & h).Value = MColumn
.Range("I12:I" & h + 1).Value = IColumn
End If
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub