Hi I'm trying to create a loop that identifies a specific string in column "B", and SUMs up the values in column "D" of the same row. So far I've been able to identify the "cash" but now I don't know how to describe column "D" of the SAME row and sum it up. Please help!
Below is what I've got so far for this loop.
Dim CD As Long
Dim text As String
Dim Z As Long
CD = 0
For Z = 1 To Range("B" & Rows.Count).End(xlUp).Row
text = Range("B" & Z).Value
If Left(text, 4) = "Cash" Then
Sum....
You could certainly do something like:
For Z = 1 To Range("B" & Rows.Count).End(xlUp).Row
text = cells(Z,2).Value
If Left(text, 4) = "Cash" Then
Sum.... Zum = Zum + cells(Z,4).value
However, the computation could be done with a simple worksheet formula
=SUMIF(B:B,"cash*",D:D)
Following the code you have provided, this would be what you are looking for:
Sub calculateSum()
Dim CD As Long
Dim text As String
Dim Z As Long
'Create a variable to store the sum and set its value to 0.
Dim sum As Double
sum = 0
CD = 0
For Z = 1 To Range("B" & Rows.Count).End(xlUp).Row
text = Range("B" & Z).Value
If Left(text, 4) = "Cash" Then
'Increase the sum by the value stored in column D on the same row.
sum = sum + Range("D" & Z).Value
End If
Next Z
'Display the final result (sum).
MsgBox "Sum: " & sum
End Sub
Related
I have a system which inputs a code to a cell on a spreadsheet. It does this by using a Vlookup to determine which date it is. If you look at the code below the nput is what does this Vlookup.
What I want it to do is move down a cell per amount the amount that will be in a combo box value called DayAmount. What would I need to enter for it to look at the next cell?
For example if the 5th of January is in A24 I want it to also enter the same code in the 6th and 7th of January which the Vlookup knows is A25 and A26.
Private Sub Submitplan_Click()
' This searches for the selected engineer
Dim EngineerFound As Range
Dim Front As Worksheet
Dim wb As Workbook
Dim area As Worksheet
Set wb = ThisWorkbook
Dim tabchange As String
Set Front = wb.Worksheets("Front")
x = Front.Cells(Front.Rows.Count, "F").End(xlUp).Row
With Front.Range("F8:F" & x)
Set EngineerFound = .Find(Engbox.Value, LookIn:=xlValues)
End With
EngRow = EngineerFound.Row
'This is the section which enters the data into the right date
tabchange = ("Area") & Front.Range("B8")
Set area = wb.Worksheets(tabchange)
y = WorksheetFunction.VLookup(CLng(CDate(Datebox.Value)), area.Range("A:B"), 2, 0)
nPut = WorksheetFunction.VLookup(Key, area.Range("A:B"), 2, 0) &
Hoursbox.Value
z = area.Range("C:C").Find(Engbox.Value).Row
If area.Cells(z, y).Value = " B/H" Then
area.Cells(z, y).Value = nPut & " " & "B/H"
ElseIf area.Cells(z, y).Value = " WK" Then
area.Cells(z, y).Value = nPut & " " & "WK"
Else: area.Cells(z, y).Value = nPut
End If
' If DayAmount <> "" Then
'End If
Call Update
Unload Me
End Sub
If I'm reading this correctly, you have a value in a combobox (will say DayAmount) which will be assigned until a that value is met.
Dim i as Long, j as Long, k as Long
i = ActiveCell.Row
j = DayAmount
k = 1
If j > 1 Then
Do until k = j-1
Cells(k+1,1).Value = Cells(i,1)>Value
k = i + k
Loop
End If
Or you could use a filldown, or .value match, and when you enter the line to the destination cell, you use:
Dim i as Long, j as Long
i = ActiveCell.Row
j = DayAmount
Range(Cells(i,1),Cells(i+j,1)).Value = "" 'input here
Note the arbitrary activecell and column 1 usage as i'm unsure exactly where this would be for you.
Regarding, specifically, the use of nPut, you can use offset to help, such as:
Range(nPut, nPut.Offset(DayAmount,0)) = WorksheetFunction.VLookup(Key, area.Range("A:B"), 2, 0) & Hoursbox.Value
Note that I haven't tested the latter and it's off the top of my head.
I am very new to coding with it, and what appears below probably looks quite horrible.
What this code currently does is do an instr search for all 3 required values appearing in a single, and absolutely defined (for test purposes), row of another table, in a separate worksheet. Copies the A cell value from that row, pastes it into the cell next to the source table row, currently being searched, and colour codes it with a green fill.
What I want it to do, is be aware that there is a whole other table of data in the other worksheet, and have it search row by row for all 3 required values matching in a given row.
Once it gets an exact hit, I want it to output the A cell value for the row that has been confirmed to be a match of all 3 required values.
The table in the other sheet is dynamic, in that it increases or decreases in total number of rows day be day.
Is anyone kind enough to be able to help me with this?
Now, here is my novice mishmash of code:
Private Sub Match_Click()
Dim i As Integer, row As Integer, narrative1 As String, transDate As Date,
amount As Double, result As String
row = 2
i = 1
narrative1 = Worksheets("Sheet2").Range("D" & row)
transDate = Worksheets("Sheet2").Range("B" & row)
amount = Worksheets("Sheet2").Range("J" & row)
Do While Cells(i, 1).Value <> ""
If narrative1 > "" Then
If InStr(1, UCase(Worksheets("Sheet1").Range("D22")), UCase(narrative1)) And
InStr(1, Worksheets("Sheet1").Range("B22"), transDate) And InStr(1,
Worksheets("Sheet1").Range("H22"), amount) Then
result = Worksheets("Sheet1").Range("A3").Value
Else
result = ""
End If
End If
i = i + 1
If Worksheets("Sheet2").Range("A" & row).Value = "" Then result = ""
Worksheets("Sheet2").Range("K" & row).Value = result
If result <> "" Then Worksheets("Sheet2").Range("K" & row).Interior.Color =
RGB(198, 224, 180)
If Worksheets("Sheet2").Range("A" & row).Value = "" Then
Worksheets("Sheet2").Range("K" & row).Interior.ColorIndex = xlNone
row = row + 1
narrative1 = Worksheets("Sheet2").Range("D" & row)
transDate = Worksheets("Sheet2").Range("B" & row)
amount = Worksheets("Sheet2").Range("J" & row)
Loop
End Sub
I think the following code will do what you expect, I've commented it to let you know what its doing (I haven't tested it, but I'm pretty sure it will do the job):
Private Sub Match_Click()
Dim i As Long 'These should be Long instead of Integer, as Excel has more cells than Integer has values.
Dim row As Long
Dim LastRow As Long
Dim LastRow2 As Long
Dim narrative1 As String
Dim transDate As String
Dim amount As Double
Dim result As String
Dim val1 As Integer
Dim val2 As Integer
Dim val3 As Integer
LastRow2 = Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, "A").End(xlUp).row 'get the lastrow of Sheet2
LastRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, "A").End(xlUp).row 'get the lastrow of Sheet1
For i = 1 To LastRow2 'loop from row 1 to last on Sheet2
narrative1 = Worksheets("Sheet2").Range("D" & i) 'get the variables to compare
transDate = Worksheets("Sheet2").Range("B" & i)
amount = Worksheets("Sheet2").Range("J" & i)
For x = 1 To LastRow ' loop through row 1 to last on Sheet1
If narrative1 <> "" Then
val1 = InStr(Worksheets("Sheet1").Cells(x, 4).Value, narrative1) 'number 4 represents column D
val2 = InStr(Worksheets("Sheet1").Cells(x, 2).Value, transDate) 'number 2 represents column B
val3 = InStr(Worksheets("Sheet1").Cells(x, 8).Value, amount) 'number 8 represents column H
If val1 > 0 And val2 > 0 And val3 > 0 Then 'if all three have been found
result = Worksheets("Sheet1").Cells(x, 1).Value 'get result
Worksheets("Sheet2").Range("K" & LastRow2 + 1).Value = result 'paster result into next free row on Sheet2 column K
If Worksheets("Sheet2").Cells(x, 1).Value <> "" Then Worksheets("Sheet2").Range("K" & LastRow2 + 1).Interior.ColorIndex = 4
Else
result = ""
End If
End If
Next x
Next i
End Sub
I want to check for duplicates in a column and my code is able to do so. But when it finds a duplicate in column L i want it to add "+1" to the integer in column c. So if "L5 and L6" are the same, I want "C5" to be "C5+1". But I have not been able to figure out how to do so.
Sub check_duplicates()
Dim x As Long
Dim LastRow As Long
LastRow = Range("L65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("L2:L" & x), Range("L" & x).Value) > 1 Then
Range("C" & x).Formula = "=LEFT(x) + 1"
End If
Next x
End Sub
That should solve your problem:
Sub check_duplicates()
Dim x As Long
Dim LastRow As Long
LastRow = Range("L65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("L2:L" & x), Range("L" & x).Value) > 1 Then
Range("C" & x) = Left(Range("C" & x), 1) + 1 & Mid(Range("C" & x), 2)
End If
Next x
End Sub
Replace Range("C" & x).Formula = "=LEFT(x) + 1" with something like Range("C" & x)=Range("C" & x) + 1. Making the formula in C5=C5+1 would be circular and would cause an error. Alternatively, set a variable equal to range C5, add 1 to it, then set range C5 to this variable. I'm assuming column C is a set of integers here and not formulas.
You can increment the value by wrapping the Left function (VBA version) around the cell value to get the value to increment by one and then use the space to extract the value to the right `"P" in your example, then bring them back together.
See the code below. It will work for instances where the number increments above single digits and it also assumes there will always be a space after the number and before the text.
Sub check_duplicates()
Dim x As Long
Dim LastRow As Long
LastRow = Range("L65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("L2:L" & x), Range("L" & x).Value) > 1 Then
Dim y As Long, x As String
'increment left number by 1
y = Left(Range("C" & x).Value, InStr(1, Range("C" & x).Value, " ") - 1) + 1
'extract text after space
x = Mid(Range("C" & x).Value, InStr(1, Range("C" & x).Value, " "))
Range("C" & x).Value = y & x ' bring together and set the cell value to new incremented value
End If
Next x
End Sub
Following is part of my program which does the follwoing function
It will look into column K and column L and create tabs according to the combinations. For example if column K has a cell value "Apple" and column L has one cell value "Orange" it will create a tab 1) Apple - Orange
The new tab will have all the rows with this combination
So once complete the running of macro , the whole data will get divided to different tabs according to the K - L combination
My problem is it is giving a run time error when entire column K or entire column L has only one value. For example if entire K column has 10 rows and all column k cells has value Apple it will give error. same goes for column L.
Dim m As Integer
Dim area As Range
Count = Range("K:K").SpecialCells(xlLastCell).Row
ActiveSheet.Range("K2:K" & Count).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ActiveSheet.Range("Z2"), Unique:=True
Columns(26).RemoveDuplicates Columns:=Array(1)
Count1 = Range("L:L").SpecialCells(xlLastCell).Row
ActiveSheet.Range("L2:L" & Count1).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ActiveSheet.Range("Y2"), Unique:=True
Columns(25).RemoveDuplicates Columns:=Array(1)
Dim arrayv As String
Dim Text1 As String
Dim arrayv1 As String
last = Range("Z2").End(xlDown).Row
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
last1 = Range("Y2").End(xlDown).Row
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
Columns(26).EntireColumn.Delete
Columns(25).EntireColumn.Delete
Dim i As Long, j As Long
Dim flag As Variant
flag = 1
A = 1
s = 2
For c = 1 To UBound(arrayv1)
For t = 1 To UBound(arrayv)
Sheets.Add().Name = "Sheet" & s
ActiveSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
With Worksheets("Sheet1")
j = 2
.Rows(1).Copy Destination:=Worksheets("Sheet" & s).Range("A" & 1)
flag = 1
For i = 2 To Count
If .Cells(i, 11).Value = arrayv(t) Then
If .Cells(i, 12).Value = arrayv1(c) Then
Text = .Cells(i, 15).Value
flag = 0
.Rows(i).Copy Destination:=Worksheets("Sheet" & s).Range("A" & j)
j = j + 1
End If
End If
Next i
If flag = 1 Then
Sheets("Sheet" & s).Delete
Else
Text1 = Left(Text, 4)
Error line when column K has only one value
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
Error line when column L has only one value
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
If there is only one value Y2 or Z2 downwards then using the Range,End property with an xlDirection of xlDown is going to reference row 1,048,576. The WorksheetFunction.Transpose method has a limit of 65,536. Anything exceeding this limit will result in,
Run-time error '13':Type mismatch.
Change the direction of the last-row-seek to look up from the bottom with xlUp.
last = Range("Z" & rows.count).End(xlUp).Row
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
last1 = Range("Y" & rows.count).End(xlUp).Row
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
In my worksheet some cells values are based on other cells
Info worksheet
A1: 5
B1: =A1
Design worksheet
A1:
Is there a way to copy and read the value in B1? I'm trying to use the value in a for loop, with no luck.
Sheets("Info").Select
For i = 1 to 5
If Range("B" & i).Value <> 0 Then
Range("B" & i).Copy Destination:=Sheets("Design").Range("A" & x)
'Sheets("Design").Range("A" & x).Value = Sheets("Offerte").Range("B" & i).Value
x = x + 1
End If
Next i
Your example doesn't seem to match the code well. The line
If Range("B" & i).Value = 1 Then
means that nothing will be copied in your example. It's looking for a cell with 1 in it. Why do you need that If statement at all?
EDIT I am guessing you're just checking that there's something in the cell to copy? I would probably do it this way:
If Trim(Range("B" & i).Value) <> "" Then
Also - did you miss out setting x=1?
There is more than one way to do it. One of them is using 'offset', which is a function that really worth understand. It basically points to a amount of rows / columns from the original cell.
Sub test()
Dim oCell As Excel.Range
Dim i As Integer
Dim x As Integer
Set oCell = Sheets("Info").Range("B1")
x = 1
For i = 1 To 5
If oCell.Offset(i, 0).Value = 1 Then
oCell.Offset(i, 0).Copy Destination:=Sheets("Design").Range("A" & x)
x = x + 1
End If
Next i
End Sub
Besides, you can assert the value instead of using the copy property. Notice it won't work unless x is an integer > 0.
Sub test2()
Sheets(3).Select
x = 1
For i = 1 To 5
If Range("B" & i).Value = 1 Then
Sheets(4).Range("A" & x).Value = Range("B" & i).Value
'Sheets("Design").Range("A" & x).Value = Sheets("Offerte").Range("B" & i).Value
x = x + 1
End If
Next i
End Sub