I have an Excel-Sheet with values in column D.
I would like to set the row height in relation to the value of cell D of each row.
Values in D are small %-values like 0.0593 %, except of the first (D4 = 31 %) and last (D92 = 40 %)
To get the small values at a reasonable height I'd like to multiply them with 10'000 - but there comes the problem with the 409 max height.
I have a script that works until it comes to the high values so I tried a if formula. But to be frankly: I have no Idea what I am doing here... I copied it together.
So the problems: working only in the range of D5-D91 and if a value should go over 409 give him something like 15px.
Thanx for your Help!
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row - 1
With Cells(i, 4)
If .Cells(i, 4).Value * 10000 > 409 Then
Rows(i).RowHeight = 12
Else
Rows(i).RowHeight = Cells(i, 4).Value * 10000
End If
End With
Next i
End Sub
Copy the below code to any standard module & Run. You may have to tweak the code as per your requirement.
Sub sample()
Dim i As Long
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 4).Value * 10000 > 409 Then
Rows(i).RowHeight = 12
Else
Rows(i).RowHeight = Cells(i, 4).Value * 10000
End If
Next
End Sub
Sub sample()
Dim i As Long
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 4).Value * 100000 > 409 Then
Rows(i).RowHeight = 20
ElseIf Cells(i, 4).Value * 100000 < 10 Then
Rows(i).RowHeight = 12
Else
Rows(i).RowHeight = Cells(i, 4).Value * 100000
End If
Next
End Sub
Related
Here is my "IN" List -
PN Qty Price
A 100 5
B 150 6
C 150 7
D 50 -9
E 100 5
F 5 9
G 20 6
I 5 7
J 15 7
J 30 10
K 100 10
K 50 10
A 20 8
Here is my "OUT" List -
PN Qty
A 120
B 10
C 110
D 60
E 100
J 20
J 10
Expected Results -
Manual Formula to calculate Price for PN = "A" = ((100*5)+(20*8))/120
PN Qty Price Total
A 120 5.5 660
B 10 6 60
C 110 7 770
D 60 -9 -540
E 100 5 500
J 20 7.75 155
J 10 10 100
I want to implement FIFO logic to calculate the Total Price in "OUT" List based on "Quantity" in "IN" List.
When you have tables like this, the outgoing button with following code:
Private Sub Outgoing_Click()
Dim pn As String
Dim ammout As Long
Dim current As Long
pn = InputBox("Which Item do you want to take out?")
ammount = InputBox("How Item do you want to take out?")
Dim cells As Long
Dim fifo As Double
counter = 1 //line where your table starts
current = 0
fifo = 0
Do Until IsEmpty(cells(counter, 13).Value Or current = ammount)
If cells(counter, 13).Value = pn Then
If cells(counter, 14).Value > (ammount - current) Then
fifo = fifo + (ammount - current) * cells(current, 15).value
current = ammount
Else
fifo = fifo + cells(counter, 14).Value * cells(counter, 15).Value
current = current + cells(counter, 14)
cells(counter, 14).Value = 0
End If
counter = counter + 1
Loop
fifo = fifo / ammount
End Sub
Should be work.
I did not match lie if you have enough in your current list and others so the validation part is missing.
your "Expected Results" doesn't match your "Manual Formula"
following this latter
Option Explicit
Sub main()
Dim cell As Range
Dim dictSum As Object
Dim dictRept As Object
Set dictSum = CreateObject("Scripting.Dictionary")
Set dictRept = CreateObject("Scripting.Dictionary")
With Worksheets("IN")
For Each cell In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
dictSum(cell.Value) = dictSum(cell.Value) + cell.Offset(, 1).Value * cell.Offset(, 2).Value
dictRept(cell.Value) = dictRept(cell.Value) + cell.Offset(, 1).Value
Next
End With
With Worksheets("OUT")
For Each cell In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
cell.Offset(, 2) = dictSum(cell.Value) / dictRept(cell.Value)
cell.Offset(, 3) = cell.Offset(, 1) * cell.Offset(, 2)
Next
End With
End Sub
I am trying to create a macro that colors cells that are higher than the previous one. I want to color only cells that follow a series of 30 cells each one higher than the previous one. In this screenshot, if I have such a series, only E35 should be colored, because from E5 to E35, each of those 30 cells are strictly higher than their predecessor (E35>E34>E33>...>E6>E5).
This is the code I tried to do:
Sub Consecutive_HigherCells()
Dim i, j As Integer
For i = 32 to 10000
For j = 1 To 30
If Cells (i,5).Value > Cells(i-j,5).Value Then
Cells(i, 5).Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
End If
Next j
Next i
End Sub
Actually the code is not working because all cells from E32 until E1000 that are AT LEAST higher than one of the 30 premious cells are colored when I run it.
I really need your help
Option explicit
Sub Consecutive_HigherCells()
Const LIMIT as long = 30
Dim i as long, j as long, Counter as long
For i = 32 to 10000
Counter = 0
For j = LIMIT to 1 step -1
If cells(i-j-1,"E").Value2 > cells(i-j,"E").value2 Then
Counter = counter + 1
Else
Exit for
End if
Next j
If counter = LIMIT then cells(i,"E").interior.color = rgb(255,255,0)
Next i
End Sub
Untested and written on mobile, sorry for bad formatting.
The code below will run through your full list and colour cells where the next one in sequence is of a lower value
Sub HighlightCells30()
Dim lr As Long, i As Long, count As Long
count = 0
lr = ActiveSheet.Range("E" & Rows.count).End(xlUp).Row
For i = 5 To lr
count = count + 1
If Range("E" & i + 1).Value < Range("E" & i).Value Then
If i <> lr And count > 30 Then
Range("E" & i).Interior.Color = vbYellow
count = 0
End If
End If
Next i
End Sub
I didnt quite get what the batches of 30 was trying to achieve?
EDIT: Updated code based on Scotts explanation below
#Chillin > Thanks for your help, you were close. I modified your code and it is now working.
Option Explicit
Sub Consecutive_HigherCells30()
Const LIMIT As Long = 30
Dim i As Long, j As Long, Counter As Long
For i = 32 To 10000
Counter = 0
For j = LIMIT To 1 Step -1
'If Cells(i - j - 1, "E").Value > Cells(i - j, "E").Value Then
If Cells(i - j - 1, "E").Value < Cells(i - j, "E").Value Then
Counter = Counter + 1
Else
Exit For
End If
Next j
If Counter = LIMIT Then Cells(i - 1, "E").Interior.Color = RGB(255, 255, 0)
Next i
End Sub
My code copies a text from a cell in Matrix 1 to all the cells that meet my criteria in Matrix 2. But I want it to copy it only to the first cell that meets my critiria in Matrix 2 and then stop.
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
For j = 2 To 2
For i = 21 To 21
If Cells(i, j).Value > 0 Then
Cells(i, j).Value = Cells(i, j).Value - 1
Cells(i, j).Offset(0, -1).Select
End If
'as it says - for EACH - so it copies in aLL the cells'
'I can't Change the range though, cause there will come a Loop eventually'
For Each cell In Range("a1:aap15")
If cell.Interior.ColorIndex = 6 Then
If cell.Value = "" Then
cell.Value = ActiveCell.Value
End If
End If
Next
Next
Next
End Sub
You can use the Exit For command to exit a for loop. It looks like you want to add it here:
If cell.Interior.ColorIndex = 6 Then
If cell.Value = "" Then
cell.Value = ActiveCell.Value
Exit For
End If
End If
Note: not tested. Let me know if you have any problems
I'm trying to write this module to compute a letter grade from a % in the next cell over and loop through the rows until the row is empty. Whats wrong with the syntax of this code? I get error: Runtime error 438: Object doesnt support this property or method at Average = Cells(i, 6).Valve
Sub Grade()
Dim Average As Double
Dim i As Integer
i = 3
Do Until IsEmpty(Cells(i, 6))
Average = Cells(i, 6).Valve
Average = Average * 100
If (Average <= 60) Then
Cells(i, 7).Valve = ("E")
End If
If (Average <= 70) Then
Cells(i, 7).Valve = ("D")
End If
If (Average <= 80) Then
Cells(i, 7).Valve = ("C")
End If
If (Average <= 90) Then
Cells(i, 7).Valve = ("B")
End If
If (Average <= 100) Then
Cells(i, 7).Valve = ("A")
End If
i = i + 1
Loop
End Sub
Change
Dim Average As Double
i As Integer
to
Dim Average As Double
Dim i As Integer
or
Dim Average As Double, i As Integer
or
Dim Average As Double, _
i As Integer
Your code needs a little more work. Use something like this:
Sub Grade()
Dim Average As Double
Dim i As Integer
i = 3
Do Until IsEmpty(Cells(i, 7))
Cells(i, 6).Value = Average
' Perhaps the above should be
' Average = Cells(i,6).Value
If (Average < 60) Then
Cells(i, 7).Valve = ("E")
End If
If (Average < 70) Then
Cells(i, 7).Valve = ("D")
End If
If (Average < 80) Then
Cells(i, 7).Valve = ("C")
End If
If (Average < 90) Then
Cells(i, 7).Valve = ("B")
End If
If (Average < 100) Then
Cells(i, 7).Valve = ("A")
End If
i = i + 1
Loop
End Sub
Just a thought on #zedfoxus post
Single line ifs don't need an end if
Sub Grade()
Dim Average As Double
Dim i As Long
i = 3
Do Until IsEmpty(Cells(i, 7))
Average = Cells(i, 6).Value
Average = Average * 100
If (Average < 60) Then Cells(i, 7).Value = ("E")
If (Average < 70) Then Cells(i, 7).Value = ("D")
If (Average < 80) Then Cells(i, 7).Value = ("C")
If (Average < 90) Then Cells(i, 7).Value = ("B")
If (Average < 100) Then Cells(i, 7).Value = ("A")
i = i + 1
Loop
End Sub
Further to this though, here is my take on the problem. I have put together a condensed routine using a 2 dimensional array and taking advantage of the worksheet function Vlookup. This works because it will find the closest thing (useful when you are using ranges of numbers)
Sub Grade()
Dim Average As Double, i As Long, MyArr As Variant
MyArr = Array(Array(60, "E"), Array(70, "D"), Array(80, "C"), Array(90, "B"), Array(100, "A"))
i = 3
Do Until IsEmpty(Cells(i, 7))
Average = Cells(i, 6).Value * 100 'Why * 100? Anyway just copied what you have done in your code
Cells(i, 7).Value = Application.WorksheetFunction.VLookup(Average, MyArr, 2)
i = i + 1
Loop
End Sub
And lastly, because the Average variable is only used once, it doesn't really need to be there (whilst it could be argued the same for MyArr it would be too bloated to include in the Vlookup, it would become hard to read), you can remove it and just reference its makeup in the Vlookup to condense the code further, and finally, we can remove i=3 and i=i+1 by using a for next loop and polling to the last row of data like so:
Sub Grade()
Dim i as long, MyArr As Variant
MyArr = Array(Array(60, "E"), Array(70, "D"), Array(80, "C"), Array(90, "B"), Array(100, "A"))
For i = 3 To Range("G" & Rows.Count).End(xlUp).Row
Cells(i, 7).Value = Application.WorksheetFunction.VLookup(Cells(i, 6).Value * 100, MyArr, 2)
Loop
End Sub
I am not sure why you are multiplying by 100 and I don't have your test data. I made my own test data but had to remove the *100 to make it work, my data was in column F.
40
50
60 E
65 E
70 D
75 D
80 C
85 C
90 B
95 B
100 A
This is the code I used:
Sub Grade2()
Dim i As Long, MyArr As Variant
MyArr = Array(Array(60, "E"), Array(70, "D"), Array(80, "C"), Array(90, "B"), Array(100, "A"))
For i = 3 To Range("F" & Rows.Count).End(xlUp).Row
Cells(i, 7).Value = Application.WorksheetFunction.VLookup(Cells(i, 6).Value, MyArr, 2)
Next
End Sub
I wonder if you want to use Formula instead of VBA.
Vlookup can do this. As below, hope this help.
I'm trying to work out how to write a Macro to replace the current Excel formula I'm using. I've tried experimenting with cell values and offsets but my knowledge of VBA is minimal. What I need it to do is to turn a single column list like this:
Cell 1
Cell 2
Cell 3
Cell 4
Cell 5
Cell 6
Into a two-column list like this:
Cell 1 Cell 2
Cell 3 Cell 4
Cell 5 Cell 6
I feel as if it should be pretty simple to achieve, but I want to avoid blank spaces and a loop will probably be required as the length of the list is likely to change each time the macro is run. Can anybody help?
I managed to work out how to do it:
Sub splitColumn()
Range("A1").Select
Do
ActiveCell.Offset(1, 0).Select
If IsEmpty(ActiveCell.Offset(-1, 1)) Then
ActiveCell.Offset(-1, 1).Value = ActiveCell
ActiveCell.EntireRow.Delete
End If
Loop Until IsEmpty(ActiveCell)
End Sub
May be you can try with the following code:
But its a bit too long...I think it may help you in providing some ideas...
Sub Splitting()
Dim i, j, k, l As Integer
RowCount = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
For i = 1 To RowCount Step 2
For j = 1 To 1
Cells(i, j + 1).Value = Cells(i, j).Value
Cells(i, j + 2).Value = Cells(i + 1, j).Value
Next j
Next i
Call Removeblanks
End Sub
Sub Removeblanks()
RowCount = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
For i = 1 To RowCount
For j = 1 To 1
If (Cells(i, j + 1).Value = "") Then
Cells(i, j + 1).Delete
Cells(i, j + 2).Delete
End If
Next j
Next i
End Sub