Sub CalculateWFR()
'select 1st sheet
Worksheets(1).Activate
'select range A:W
Worksheets(1).Cells.Select
Columns("A:W").Select
'copy paste sheet programare in results
Sheets("Programare").Range("A:W").Copy Destination:=Sheets("Result").Range("A:W")
'compare values from column U with column V and put +/-/= if value from U2 is higher,smaller or equals value from column V2
Dim X As Integer Dim y As Integer
X = Worksheets("Result").Range("U2").Value
y = Worksheets("Result").Range("V2").Value
If X > y Then
Worksheets("Result").Range("X2") = "+"
ElseIf X < y Then
Worksheets("Result").Range("X2") = "-"
ElseIf X = y Then
Worksheets("Result").Range("X2") = "="
End If
End Sub
I am trying to loop the above code on column X, which has over 1000 Rows. Also there are no blank spaces. How can I do this?
As #Zerk suggested try to figure out how this works.
Looping and Selecting is not required at all.
Try to think this as you were to put formula in column X and then google how to put that formula through VBA.
Sub test()
Sheets("Programare").Range("A:W").Copy Destination:=Sheets("Result").Range("A:W")
Sheets("Result").Range("X2:X1000").Formula = "=IF(U2>V2,""+"",IF(V2>U2,""-"",IF(U2=V2,""="","""")))"
End Sub
Related
I am a bit confused as to how to implement code for Text boxes. I am trying to set up a form which displays a text box, for which the user has the option to enter in the values (parameters) , which then are entered into another subprogram and runs that subprogram. For example, in the following code:
Option Explicit
Sub FillSampleTable()
'This will fill an x by y grid of numbers incrementing to use for testing purposes
Dim x As Double
Dim y As Double
Dim z As Double
Dim OffsetColumn As Integer
Dim offsetrows As Integer
Dim a As Long
Application.ScreenUpdating = False
a = 10
OffsetColumn = 1
offsetrows = 1
z = 0
For x = 1 To a
For y = 1 To a
z = z + 1
Cells(x + offsetrows, y + OffsetColumn).Select
Cells(x + offsetrows, y + OffsetColumn).Value = z
Next y
Next x
Application.ScreenUpdating = True
End Sub
I would want to have a text box to prompt the user for the value of 'a', and once that value is loaded, then this subprogram is run. If no value is entered, then it would shoot an error msgbox and return to the entry screen.
When I click the box I get:
Private Sub GridSize_Change()
'I renamed text box GridSize
End Sub
but don't know what to do with this. MS Excel v 2016.
What you need is an inputbox.
You could do a simple :
a = InputBox("Enter number a")
Since you need a to be a positive integer, you should at least specify the datatype accepted by the inputbox to 1 (number). But you probably also need to make sure it is a positive integer.
I'm creating a sales channel map and use the .Left/.Top w/ + (.5*.width/.Height) to get the center of the images I'm connecting. I'd like to also use this method to select the cell that corresponds to this coordinate.
The only solution I can think of (and could implement, but I'd rather avoid an iterative approach) would be something like:
Sub FindCellLoc(DesiredYLocation,DesiredXLocation)
'Finds the Column Number of the X coordinate
RunningTotalX = 0
For X = 1 to 100000000
RunningTotalX = RunningTotalX + Cells(1,X).width
if RunningTotalX >= DesiredXLocation then
TargetCol = Cells(1,X).Column
Goto FoundCol
End if
Next X
FoundCol:
'Finds the Column Number of the X coordinate
RunningTotalY = 0
For Y = 1 to 100000000
RunningTotalY = RunningTotalY + Cells(Y,1).width
if RunningTotalY >= DesiredYLocation then
TargetRow = Cells(Y,0).Column
Goto FoundRow
End if
Next Y
FoundRow
Cells(TargetRow,TargetCol).Select
End Sub
I'd really appreciate any input about a non-iterative approach.
Thanks,
-E
Here is a routine to select a cell based on the x and y position:
Public Sub SelectCellByPos(x, y)
With ActiveSheet.Shapes.AddLine(x, y, x, y)
.TopLeftCell.Select
.Delete
End With
End Sub
I assume you have access to the shape object from which you got the desired locations. If so, you could do something like
Function GetCenterCell(shp As Shape) As Range
Dim lRow As Long, lCol As Long
lRow = (shp.TopLeftCell.Row + shp.BottomRightCell.Row) \ 2
lCol = (shp.TopLeftCell.Column + shp.BottomRightCell.Column) \ 2
Set GetCenterCell = shp.Parent.Cells(lRow, lCol)
End Function
Sub test()
Dim shp As Shape
Set shp = Sheet1.Shapes(1)
Debug.Print GetCenterCell(shp).Address
End Sub
That won't give you the exact middle if there isn't an exact middle. It will skew top and left as the integer division truncates (I think). But using the TopLeftCell and BottomLeftCell properties will be far superior to iterating, even if it means you're iterating through the cells in that range or some other implementation.
I am having trouble figuring out how to subtract two ranges from each other, some cells in range H:H have "#N/A" while in range D:D there are no errors. I know in Excel it's a simple "=H2-D2" and drag that down but I'm in the process of recording a Macro and wanted to automate the subtraction as well. So far this is what I have:
Dim quantity1, quantity2, rIntersect, Qdiff, x As Range
Set quantity1 = Range("D:D")
Set quantity2 = Range("H:H")
Set rIntersect = Intersect(quantity1, quantity2)
For Each x In quantity1
If Intersect(rIntersect, x) Is Nothing Then
If Qdiff Is Nothing Then
Set Qdiff = x
Else
Set Qdiff = Application.Union(Qdiff, x)
End If
End If
Next x
Range("J2").Select
Dim lastRowJ As Long
lastRowJ = Range("A" & Rows.Count).End(xlUp).Row
Range("J2").AutoFill Destination:=Range("J2:J" & lastRowJ)
Place this procedure in a standard code module:
Public Sub Subtract()
[j2:j99] = [h2:h99-d2:d99]
End Sub
If you like how that works, I'm happy to embellish it so that it is not hard-coded for 98 rows only. Let me know.
UPDATE
Here is a version that will deal with any number of rows. It keys off of column D. So if there are 567 numbers in column D, then you will get 567 corresponding (subtracted) results in column J.
This assumes that the data start in row 2, and that there are no blank cells until the numbers in column D end.
If you are going to call this from the Macro Dialog then you should keep it Public. If on the other hand you are going to call it from another procedure in the same module, then you can make it Private.
Here is the enhanced solution:
Public Sub Subtract()
Dim k&
Const F = "iferror(h2:h[]-d2:d[],0)"
k = [count(d:d)]
[j2].Resize(k) = Evaluate(Replace(F, "[]", k + 1))
End Sub
Note that the routine now handles the errors and places a ZERO value in column J when the corresponding value in column H is an error. If you would prefer to have something other than a ZERO (like a blank for instance) when there are errors in column H, just let me know and I'll update to whatever you want.
UPDATE 2
Here is how to handle displaying blanks instead of zeroes:
Public Sub Subtract()
Dim k&
Const F = "iferror(if(h2:h[]-d2:d[]=0,"""",h2:h[]-d2:d[]),0)"
k = [count(d:d)]
[k2].Resize(k) = Evaluate(Replace(F, "[]", k + 1))
End Sub
How to convert this formula to application.worksheetfunction.sumproduct with assigning range?
Set wb2 = ThisWorkbook)
Set ws1 = wb2.Sheets("b")
Set ws17 = wb2.Sheets("c")
Set ws18 = wb.Sheets("a")
Set ws19 = wb.Sheets("d")
ws18.range("A:A")
Evaluate("SUMPRODUCT((A:A=J2)*(E:E=F:F))") + _
'Evaluate("SUMPRODUCT((A:A=J2)*(E:E>F:F)*(F:F>0))")
THANKS SO MUCH!
Converting a formula to a vba worksheet function equivalent is often possible but can be tricky as only a limited subset of functions are available. (See also here: Adding or multiplying variants in VBA)
Based on the example given, i think the following two functions should return the same result:
Sub TestEvaluate()
With Sheet1
x = .Evaluate("SUMPRODUCT((A1:A10=J2)*(E1:E10=F1:F10))")
y = .Evaluate("SUMPRODUCT((A1:A10=J2)*(E1:E10>F1:F10)*(F1:F10>0))")
End With
Debug.Print x + y
End Sub
Sub TestWorksheetFunction()
With Sheet1
a = .Range("A1:A10").Value2
e = .Range("E1:E10").Value2
f = .Range("F1:F10").Value2
Set j = .Range("J2")
End With
With Application
x = .SumProduct(.CountIf(j, a), .Delta(e, f))
y = .SumProduct(.CountIf(j, a), .Delta(.GeStep(f, e)), .Delta(.GeStep(0, f)))
End With
Debug.Print x + y
End Sub
I am fairly new to VBA and having some general obstacles with basic syntax. I am using the below code to trim leading spaces and color code an ActiveSheet I am currently working on.
I have another Worksheet called "Country" that I would like to apply the same logic to the current sheet I am using. I am also having difficulties using the most efficient code to find any cells with values of "AcctTotal" , " CurrTotal" and " BravoTotal" (there are about 14,000 rows of data). I am currently highlighting the whole spreadsheet and utilizing "UsedRange" to find these cells.
To sum it up:
I would like to trim leading spaces and color code any values of "AcctTotal" , " CurrTotal" and " BravoTotal" in two worksheets: "Currency" and "Country"
Sub ColorCodeCurrency()
Dim r As Range
For Each r In Selection
If r.Value = " AcctTotal" Then
r.Value = LTrim(r.Value)
Intersect(r.EntireRow, ActiveSheet.UsedRange).Interior.ColorIndex = 15
End If
Next r
Dim s As Range
For Each s In Selection
If s.Value = " CurrTotal" Then
s.Value = LTrim(s.Value)
Intersect(s.EntireRow, ActiveSheet.UsedRange).Interior.ColorIndex = 40
End If
Next s
Dim t As Range
For Each t In Selection
If t.Value = " BravoTotal" Then
t.Value = LTrim(t.Value)
Intersect(t.EntireRow, ActiveSheet.UsedRange).Interior.ColorIndex = 35
End If
Next t
End Sub
Most of the problem is that you're doing the same thing three times. The 'For Each' statement is going through every cell three times. If you joined it into
for each r in selection
if r.value ="AcctTotal" then
'do something
elseif r.value = "CurrTotal" then
'do something else
elseif r.value = "BravoTotal" then
'do the third thing
end if
In addition to what Maudise said, when you refer to your data, you can use syntax like:
Sheets("Country").Range("A1:E14000")
If it's possible to make changes to your source data, you may find it helpful to format it as a table for easy reference. Use the Name Manager to give the table a useful name. Then, you can say something like:
For Each r In Sheets("Country").Range("CountryTable")
You could try this way:
Public Sub ColorCode ()
Dim i As Integer, j As Integer, m As Integer, n As Integer
i = Range("A:A").End(xlDown).Row
j = Cells.End(xlToRight).Column
For m = 1 To i
For n = 1 To j
If Cells(m, n).Value < 50 Then
Cells(m, n).Interior.ColorIndex = 13
End If
Next n
Next m
End Sub
One solution is to call this code placed in a module into "This workbook" in "Private Sub Workbook_Open()".