I have a name of companies and tickers in Column P and Q and What I am trying to get is voookup of Column R to Column P and if Value Matches then paste it to Column T. I have this voolup code = "=VLOOKUP(R2,P:Q,2,FALSE)" and trying to covert it to VBA.
Dim i As Integer
Dim p, q, r, t As String
Sub esindia()
For i = 2 To 20000 Step 1
p = Sheet1.Range("p2" & i)
q = Sheet1.Range("q2" & i)
r = Sheet1.Range("r2" & i)
t = Sheet1.Range("t2" & i)
If r = p Then
t = r
Sheet1.Range("t" & i) = r
Else
p = r
Sheet1.Range("t" & i) = r
End If
Next
End Sub
Am I Missing anything here, help is much appreciated.
The With block is a lot and can be broken out into individual variables for better readability if you wanted.
Breaking it apart
ThisWorkbook
Sheets("Sheet1")
Range("T2:T" & LROw)
Where LRow = Range("T" & Rows.Count).End(xlUp).Row)
Sub MyVlookup()
With ThisWorkbook.Sheets("Sheet1").Range("T2:T" & Range("T" & Rows.Count).End(xlUp).Row)
.Formula = "=VLOOKUP(R2, P:Q, 2, 0)"
.Value = .Value 'Remove this if you want the formula to show in the sheet
End With
End Sub
Related
I am using VBA to write a Macro and it is working exactly as I want, except that I would like my formulas to loop through the sheets instead of using data on 'SAFO-1', 'SAFO-1' refers to the fish Salvelinus fontinalis (SAFO). I have many fish species (e.g., Morone saxatilis (MOSA)) and it would be way more pratical if I could refer to the sheet number instead of their name. Unfortunately, I do not decide sheet names and they have to stay as they are because we're working on shared projects with unique name for every samples. Sheets name change between projects and I want to be able to use my code in all of them. Here is my current code:
Sub Mean()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Sheet As Integer
k = 4
i = Application.Sheets.Count
For Sheet = 2 To i
Worksheets(Sheet).Select
j = 3
Do While ActiveCell.Value <> "0"
Range("A" & j).Select
If ActiveCell.Value = "0" Then
Range("A1").Copy
Worksheets("Mean").Range("A" & Sheet + 1).PasteSpecial Paste:=xlPasteValues
Worksheets("Mean").Range("B" & Sheet + 1).Formula = "=(('SAFO-1'!B80)-('SAFO-1'!B75))"
Worksheets("Mean").Range("C" & Sheet + 1).Formula = "=(('SAFO-1'!C80)-('SAFO-1'!C75))"
For k = 4 To 41
Worksheets("Mean").Cells(Sheet + 1, k).FormulaR1C1 = "=AVERAGE('SAFO-1'!R" & j + 10 & "C" & k & ":R" & j - 9 & "C" & k & ")"
Next k
Else
j = j + 1
End If
Loop
Next Sheet
Range("B1:AP2").Copy Worksheets("Mean").Range("A1")
Worksheets("Mean").Select
End Sub
My idea is to replace 'SAFO-1' by 'Sheet1', to be enventually able to write something like :
Worksheets("Mean").Cells(Sheet + 1, k).FormulaR1C1 = "=AVERAGE('Sheet "& Sheet")'!R" & j + 10 & "C" & k & ":R" & j - 9 & "C" & k & ")"
Thanks in advance!
William Fortin
First, we are going to stop using .Select and instead use object handles. I'm not entirely sure where the name of your sheet comes from but I'm going to assume that it's related to the loop and use that as an example. We get an object handle on the sheet using it's number Set currentSheet = Worksheets(Sheet) and then we can grab it's name and use that where we need to in the formula currentSheet.Name.
I hope that even if this code isn't a complete solution that it shows you how to get where you are going.
Option Explicit
Public Sub Mean()
Dim j As Long
Dim k As Long
Dim Sheet As Long
k = 4
For Sheet = 2 To Application.Sheets.Count
Dim currentSheet As Worksheet
Set currentSheet = Worksheets(Sheet)
j = 3
Do
Dim currentCell As Range
Set currentCell = currentSheet.Range("A" & j)
If currentCell.Value = "0" Then
With Worksheets("Mean")
.Range("A" & Sheet + 1).Value = currentSheet.Range("A1").Value
.Range("B" & Sheet + 1).Formula = "=(('" & currentSheet.Name & "'!B80)-('" & currentSheet.Name & "'!B75))"
.Range("C" & Sheet + 1).Formula = "=(('" & currentSheet.Name & "'!C80)-('" & currentSheet.Name & "'!C75))"
For k = 4 To 41
.Cells(Sheet + 1, k).FormulaR1C1 = "=AVERAGE('" & currentSheet.Name & "'!R" & j + 10 & "C" & k & ":R" & j - 9 & "C" & k & ")"
Next k
End With
Else
j = j + 1
End If
Loop While currentCell.Value <> "0"
Next Sheet
currentSheet.Range("B1:AP2").Copy Worksheets("Mean").Range("A1")
Worksheets("Mean").Select
End Sub
We can create an array of worksheet names in VBA and use them to create the formulas we put in the sheets. For example:
Sub useNumber()
sh = Array("big worksheet name", "collosal worksheet name", "mammoth worksheet name", "tiny worksheet name")
Sheets("Sheet1").Range("A1").Formula = "=SUM('" & sh(1) & "'!A3:A6)"
End Sub
If you have many sheets, use a For loop to fill the array rather than the Array() function.
running this creates:
=SUM('collosal worksheet name'!A3:A6)
In Sheet1 cell A1
This approach makes looping over data sheets easier:
Sub useNumberloop()
sh = Array("big worksheet name", "collosal worksheet name", "mammoth worksheet name", "tiny worksheet name")
For i = 1 To 4
Sheets("Sheet1").Range("A" & i).Formula = "=SUM('" & sh(i - 1) & "'!A3:A6)"
Next i
End Sub
I came across a macro that compares data pasted in column B with column A and highlights column B if not an Exact match with column A.
Sub HighlightNoMatch()
Dim r As Long
Dim m As Long
m = Range("B" & Rows.Count).End(xlUp).Row
Range("B1:B" & m).Interior.ColorIndex = xlColorIndexNone
For r = 1 To m
If Evaluate("ISERROR(MATCH(TRUE,EXACT(B" & r & ",$A$1:$A$30),0))") Then
Range("B" & r).Interior.Color = vbRed
End If
Next r
End Sub
How do I change the code to achieve as below -
I want the code to highlight Column F on sheet2, if it is not an exact match with data in Column B on sheet1."
Rather than having a fixed range ($A$1:$A$30) I would loop through each value in the range and check for a match:
Sub HighlightNoMatch()
Dim t As Long
Dim m As Long
m = Worksheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Row
t = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
Worksheets("Sheet2").Range("F1:F" & m).Interior.ColorIndex = xlColorIndexNone
For x1 = 1 To m
For x2 = 1 To t
If Worksheets("Sheet2").Range("F" & x1).Value = Worksheets("Sheet1").Range("B" & x2).Value Then
Exit For
ElseIf Worksheets("Sheet2").Range("F" & x1).Value <> Worksheets("Sheet1").Range("B" & x2).Value And x2 = t Then
Worksheets("Sheet2").Range("F" & x1).Interior.Color = vbRed
End If
Next x2
Next x1
End Sub
column A and Column C is the range and column B is the reference value which I have to compare with Column A and Column C .
Eg: (B>A) and (B
Basically I want to check whether column B falls between Column A and column C
Here is the code which I have prepared but this is not working and this is for single cell:
Sub a()
Dim x As Integer
Dim y As Integer
x = Worksheets("Sheet1").Range("A1").Value
y = Worksheets("Sheet1").Range("B1").Value
Z = Worksheets("Sheet1").Range("C1").Value
If Z > x Then
Worksheets("Sheet1").Range("D1") = "Correct"
End If
End Sub
you can do this way:
Sub main()
With Worksheets("Sheet1")
With .Range("D1:D" & .Cells(.Rows.Count, 1).End(xlUp).row)
.FormulaR1C1 = "=IF(AND(RC2>=RC1,RC2<=RC3),""Correct"",""Wrong"")"
.Value = .Value
End With
End With
End Sub
You can use a simple formula for this:
=IF(AND(B1>=A1,B1<=C1),"Correct","Wrong")
If you still need vba then use this:
Sub RANGEFALL()
Dim wk As Worksheet, frow As Long, i As Long
Set wk = Sheet1
frow = wk.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To frow
If wk.Range("B" & i).Value >= wk.Range("A" & i).Value And wk.Range("B" & i).Value <= wk.Range("C" & i).Value Then
wk.Range("D" & i).Value = "Correct"
Else
wk.Range("D" & i).Value = "Wrong"
End If
Next i
End Sub
I am working on an accounting VBA program that will post Journal entries to a Ledger, and then generate trial balances (i.e. print out the values on a new sheet following "Bal. " in the Ledger). To do this, I need a way to assign the numerical part of the balance cells to a variable or collection. Unfortunately, when I use Debug.Print I see the only value stored is 0 (I am testing just with Common Stock). My expression is: y = Application.Evaluate("=SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1])") where y represents the balance of Common Stock. How do I properly store the balance value in a variable?
' TODO BE ABLE TO RUN MULTIPLE TIMES
' CHECK FOR POSTED MARK & START WRITING WHEN
' r = "one of the keys", or just creates new Ledger Worksheet every time
Sub MacCompileData()
Application.ScreenUpdating = False
Dim lastRow As Long, x As Long
Dim data, Key
Dim r As Range
Dim cLedger As Collection, cList As Collection
Set cLedger = New Collection
With Worksheets("Journal")
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For x = 2 To lastRow
Key = Trim(.Cells(x, 2))
On Error Resume Next
Set cList = cLedger(Key)
If Err.Number <> 0 Then
Set cList = New Collection
cLedger.Add cList, Key
End If
On Error GoTo 0
cLedger(Key).Add Array(.Cells(x, 1).Value, .Cells(x, 3).Value, .Cells(x, 4).Value)
Worksheets("Journal").Cells(x, 5).Value = ChrW(&H2713)
Next
End With
With Worksheets("Ledger")
Dim IsLiability As Boolean
Dim y As Integer
For Each r In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
If r <> "" Then
On Error Resume Next
Key = Trim(r.Text)
If Key = "LIABILITIES" Then
IsLiability = True
End If
data = getLedgerArray(cLedger(Key))
If Err.Number = 0 Then
Set list = cLedger(Key)
x = cLedger(Key).Count
With r.Offset(2).Resize(x, 3)
.Insert Shift:=xlDown, CopyOrigin:=r.Offset(1)
.Offset(-x).Value = data
If IsLiability Then
.Offset(0, 2).Resize(1, 1).FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
' LOOK HERE FOR Y
y = Application.Evaluate("=SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1])")
Debug.Print "Common Stock Balance Equals "; y
Else
.Offset(0, 1).Resize(1, 1).FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
End If
r.Offset(1).EntireRow.Delete
End With
End If
On Error GoTo 0
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getLedgerArray(c As Collection)
Dim data
Dim x As Long
ReDim data(1 To c.Count, 1 To 3)
For x = 1 To c.Count
data(x, 1) = c(x)(0)
data(x, 2) = c(x)(1)
data(x, 3) = c(x)(2)
Next
getLedgerArray = data
End Function
Here is a solution that I was able to figure out, though I am not sure if it is the most efficient. In line before the formula is set, I set a Range named BalanceCell to the cell where the formula will be written. I then used the Mid Function to get the string number value from the cell (since the length of "Bal. " is always 5 characters) after the formula is put into BalanceCell.
If IsLiability Then
Set BalanceCell = .Offset(0, 2).Resize(1, 1)
BalanceCell.FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
y = Mid(BalanceCell.Value, 6, Len(BalanceCell.Value))
Debug.Print "Common Stock Balance is "; y
Bit new to VBA. It seems quite simple though; am not able to figure it out how to use Offset function and While/Do while loop here.
I am making an excel form where columns A to L will have values.
Out of which few columns are mandatory. Those are A, B, C, D, F, G, H, I, J, L.
Which means those can't be left blank and other columns can be blank.
My excel looks like below.
I have written a code where it checks whether mandatory columns have values or not.
The code is as below :
Dim celadr, celval As Variant
Dim cell As Variant
Dim LastRow As Long
LastRow = Range("A65536").End(xlUp).Row
On Error GoTo 0
shname = ActiveSheet.Name
Dim celArray, arr, Key1, KeyCell As Variant
celArray = ("A,B,C,D,F,G,H,I,J,L")
arr = Split(celArray, ",")
For Key1 = LBound(arr) To UBound(arr)
KeyCell = arr(Key1)
Range(KeyCell & "2:" & KeyCell & "" & LastRow).Select
'Selection.Clearformats
For Each cell In Selection
celadr = cell.Address
celval = cell.Value
If celval = "" Then
Range(celadr).Interior.Color = vbRed
strErr = Range(celadr).Value
Sheets("Observations").Range("A65536").End(xlUp).Offset(1, 0).Value = IIf(strErr = "", "Empty Found", strErr)
strstr = "'" & shname & "'!" & Range(celadr).Address(0, 0)
Sheets("Observations").Hyperlinks.Add Anchor:=Sheets("Observations").Range("A65536").End(xlUp), Address:="", SubAddress:= _
strstr, TextToDisplay:=IIf(strErr = "", "Empty Found", strErr)
End If
Next cell
Next Key1
The result of this code is;
1) between each two school records a row may be left blank.
My above code will color such all rows also in red background.
(It should not happen)
2) Columns B, C, D, F, G, H can have values only in the same row in which school_name is mentioned.
So, if following rows for same school are left blank then those also will be colored in red background.
(It should not happen).
So; I want to make small correction to code:
I want to add a condition to code:
"When there is a value in Column A; then only the above code should be exceuted."
I tried to achieve it as I have written in below Code. Still, am not upto.
I have commented all such lines of code which were giving me error (from below code):
Dim celadr, celval, celadr1, celval1 As Variant
Dim cell, cell1 As Variant
Dim LastRow As Long
LastRow = Range("A65536").End(xlUp).Row
On Error GoTo 0
shname = ActiveSheet.Name
Dim celArray, arr, Key1, KeyCell As Variant
'Range("A2:A" & LastRow).Select
'For Each cell1 In Selection
'celadr1 = cell1.Address
'celval1 = cell1.Value
'Do While Len(celval1) >= 1
celArray = ("A,B,C,D,F,G,H,I,J,L")
arr = Split(celArray, ",")
For Key1 = LBound(arr) To UBound(arr)
KeyCell = arr(Key1)
Range(KeyCell & "2:" & KeyCell & "" & LastRow).Select
'Selection.Clearformats
For Each cell In Selection
celadr = cell.Address
celval = cell.Value
' May be another loop over here to increment value in offset function according to column number.
If celval = "" Then 'And Offset Function Referring to column A, same row.
Range(celadr).Interior.Color = vbRed
strErr = Range(celadr).Value
Sheets("Observations").Range("A65536").End(xlUp).Offset(1, 0).Value = IIf(strErr = "", "Empty Found", strErr)
strstr = "'" & shname & "'!" & Range(celadr).Address(0, 0)
Sheets("Observations").Hyperlinks.Add Anchor:=Sheets("Observations").Range("A65536").End(xlUp), Address:="", SubAddress:= _
strstr, TextToDisplay:=IIf(strErr = "", "Empty Found", strErr)
End If
' End If
Next cell
Next Key1
' Loop
Can someone guide me how I can make correct use of offset function/while loops here?
Edit:
Assume, XYZ School don't have value for No. of Teachers
And
PQRS School don't have value for No. of students
My Current output is as in below image:
Where as Expected Output is:
I think the below code should work - try it out and let me know if there are any issues:
Sub Your_Macro()
Dim celArray, item As Variant
Dim LastRow, x As Long
LastRow = Cells(rows.Count, "A").End(xlUp).row
celArray = ("A,B,C,D,F,G,H,I,J,L")
celArray = Split(celArray, ",")
For x = 2 To LastRow
If Not IsEmpty(Cells(x, "A")) Then
For Each item In celArray
If IsEmpty(Cells(x, item)) Then
Cells(x, item).Interior.Color = vbRed
End If
Next item
End If
Next x
End Sub