I'm trying to add a Vlookup piece to a long macro that I'm working on to eliminate some daily data manipulation work.
Essentially everyday I have four new columns of data that I compare to the day befores, using vlookup. The four new columns sit in columns C-F and the old data in columns M-P. I vlookup column D against column M, with the formula in column G.
I'm running into a problem of how to be flexible with the range I give the macro to use each day as I don't want to constantly change it. The amount of rows will fluctuate between 10,000-30,000.
Here is my code- I'm probably thinking about this all wrong.
Sub Lookup()
Dim i, LastRow
Set i = Sheets("data").Range("F5").End(xlUp)
If Cells(i, "F5").Value <> "" Then
Range(i, "G").Value = WorksheetFunction.VLookup(Cells(i, "D"), Range("N").End(xlDown), 1, False)
End If
End Sub
Give this a go
Sub Sheet2_Button1_Click()
Dim Rws As Long, rng As Range, Mrng As Range, x
Rws = Cells(Rows.Count, "D").End(xlUp).Row
Set rng = Range(Cells(1, "G"), Cells(Rws, "G"))
Set Mrng = Range("M1:M" & Rws)
rng = "=IFERROR(VLOOKUP(D1, " & Mrng.Address & ",1,0),""Nope"")"
'----------If you want it to be just values uncomment the below line--------------
' rng.Value=rng.Value
End Sub
You have some backwards range references. I can't speak to the vlookup call, but you can start by looking at this part:
If Cells(i, "F5").Value <> "" Then
Range(i, "G").Value = WorksheetFunction.VLookup(Cells(i, "D"), Range("N").End(xlDown), 1, False)
End If
Try changing it to this to fix the range declarations:
If Range("F" & i).Value <> "" Then
Range("G" & i).Value = WorksheetFunction.VLookup(Range("D" & i), Range("N").End(xlDown), 1, False)
End If
Related
I need to combine multiple macros to a single macro that executes on button click. Kindly excuse me if I write anything wrong since I am completely new to excel macros and vb.
Following is the scenario.
Steps:
Calculate total
Extract reference
Compare total field value for matching reference and mark that as "Complete" if sum of total for matching references calculates to ).
(Explained...)
First i calculate the debit and credit amount to a new column called total, for this, initially I used the SUM function. after that I tried the same using the macro that executes on button click
(old macro)
Private Sub getTotal_Click()
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 5 To lastRow
Range("K" & i).Value = Range("F" & i).Value + Range("G" & i).Value
Next i
End Sub
This was so much time consuming (took around 2 hrs when executed on 75k records) than when using the formula (which finished in minutes). I am still not able to understand the reason for this. However modifiying to Dy.Lee's answer below, it took only seconds to calculate the total.
(modified based on Dy.Lee's answer)
Private Sub getTotal_Click()
Dim vDB As Variant, vR() As Variant
Dim i As Long, n As Long, lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
vDB = .Range("R5", "S" & lastRow)
n = UBound(vDB, 1)
ReDim vR(1 To n, 1 To 1)
For i = 1 To n
vR(i, 1) = vDB(i, 1) + vDB(i, 2)
Next i
.Range("AL5").Resize(n) = vR
End With
End Sub
Now moving on to the second macro which I used to extract a pattern from strings in a column D and E.
Function extractReference(cid_No As String, pm_source As String)
Dim regExp As Object, findMatches As Object, match As Object
Dim init_result As String: init_result = ""
Set regExp = CreateObject("vbscript.regexp")
With regExp
.Global = True
.MultiLine = False
.Pattern = "(?:^|\D)(\d{5,6})(?!\d)"
End With
Set findMatches = regExp.Execute(pm_source)
For Each match In findMatches
init_result = init_result + match.SubMatches.Item(0)
Next
If init_result <> "" Then
extractReference = cid_No & " | " & init_result
Else
extractReference = ""
End If
End Function
This macro was working fine.
Finally I used the following function after copying both the extracted reference and total to a new sheet and creating a datatable for that
=IF(ISBLANK([#Reference]), "", (IF((ROUND(SUMIFS([Total],[Reference],[#Reference]),2)=0), "complete", "")))
This also worked fine.
Now what I actually want is I need to avoid creating any new data tables or sheets and preform all this within current sheet on a single button click. Is there anyway that can be done without making the macro a time consuming process? Your help is higly appreciated!
Thanks in Advance
for the first part try:
Private Sub getTotal_Click()
Dim lastRow As Long
Dim sumRange As Range
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set sumRange = Range(Range("K5"), Range("K" & lastRow))
sumRange.FormulaR1C1 = "=RC[-5]+RC[-4]"
sumRange.Copy
sumRange.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
also, if you still want to loop notice that calling cell like .Cells(1, 1) is faster than Range("A1")
You need using Variant Array. It is faster.
Private Sub getTotal_Click()
Dim vDB As Variant, vR() As Variant
Dim i As Long, n As Long, lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
vDB = .Range("f5", "g" & lastRow)
n = UBound(vDB, 1)
ReDim vR(1 To n, 1 To 1)
For i = 1 To n
vR(i, 1) = vDB(i, 1) + vDB(i, 2)
Next i
.Range("k5").Resize(n) = vR
End With
End Sub
I have a macro right now that pulls data from a different sheet into a new sheet, then formats the data into a form I can use. The issue I have is that some of the PNs that I pull from the other sheet are in different cells for ease of viewing. (For example, the top level PN is in cell C2 and any parts that are a part of the part in C2 may be listed in D3, to show it's a sub-part).
I need code that will shift all PNs across varying columns into a single column. Once all PNs are moved, the other columns should be deleted (D through F). The data ranges from column C to F. Depending on the table the macro pulls data from, the length of the data varies. The macro will need to be able to handle this.
Here's an example of what my sheet looks like after my macro runs:
I'm trying to check column C for empty rows. If say C3 is empty, I then want to check D3 for text. If there is text, I want text in D3 to move to C3. If there is no text, check E3. Same process repeated. From what I've found online, I have this code so far (however, it doesn't run properly in my macro)...
'Copy PNs that are out of line and paste them in the correct column
Dim N As Long, i As Long, j As Long
Set ws1 = Worksheets("KDLSA")
N = ws1.Cells(Rows.Count, "C").End(xlUp).Row
j = 4
For Each cell In Range("D2:F" & ws1.Cells(Rows.Count, "F").End(xlUp).Row)
If cell.Value = "" Then 'if cell C is blank, I want to shift the text to fill column C
ws1.Range("C" & j).Value = ws1.Range("D" & cell.Row).Value 'copy PN in column E to column D - this needs to be more robust to cover my range of columns rather than just D and E
j = j + 1
End If
Next cell
Any help is appreciated.
Change your "For" block to:
With ws1.UsedRange
lastRow = .Rows(.Rows.Count).Row
End With
For Each cell In Range("C2:C" & lastRow)
If cell.Value = "" Then
thisRow = cell.Row
For Each horCell In Range(Cells(thisRow, "D"), Cells(thisRow, "F"))
If Not horCell.Value = "" Then
cell.Value = horCell.Value
Exit For
End If
Next horCell
End If
Next cell
Range("D:F").EntireColumn.Delete
By cycling only through column C, you can loop through D-F only if C is blank, and when you find the one with data, it puts it in C.
If you also need dynamic range on the number of columns, then do:
With ws1.UsedRange
lastRow = .Rows(.Rows.Count).Row
lastColumn = .Columns(.Columns.Count).Column
End With
For Each cell In Range("C2:C" & lastRow)
If cell.Value = "" Then
thisRow = cell.Row
For Each horCell In Range(Cells(thisRow, "D"), Cells(thisRow, lastColumn))
If Not horCell.Value = "" Then
cell.Value = horCell.Value
Exit For
End If
Next horCell
End If
Next cell
Range(Cells(2, "D"), Cells(2, lastColumn)).EntireColumn.Delete
Or with a correct lastRow in your for loop "to" range, change your code to
If Not cell = "" then
ws1.range ("C" & cell.Row).Value = cell.Value
End if
You are looping through columns D-F, so "cell" is a cell in that range, not in column C. You therefore want to test for the ones that are NOT empty and then put their values in the corresponding cell in column C. :-)
As Tehscript mentioned you dont need a macro. If you nevertheless want to use a macro (maybe your real case is more complex than the example) here is a starting point for you.
The example below will shift the cells only once. So you might want to execute the loop several times. (You could also loop over the rowIndex and use a while loop for each row.)
The code could be further refactored but I hope this way it is easy to read.
Sub ShiftCells()
Dim myWorkSheet As Worksheet
Set myWorkSheet = Worksheets("Tabelle1")
Dim maxRowIndex As Long
maxRowIndex = GetMaxRowIndex(myWorkSheet)
Dim rowIndex As Long
Dim columnIndex As Long
Dim leftCell As Range
Dim rightCell As Range
For Each Cell In Range("C2:F" & maxRowIndex)
If Cell.Value = "" Then
shiftedCell = True
rowIndex = Cell.Row
columnIndex = Cell.Column
Set leftCell = myWorkSheet.Cells(rowIndex, columnIndex)
Set rightCell = myWorkSheet.Cells(rowIndex, columnIndex + 1)
leftCell.Value = rightCell.Value
rightCell.Value = ""
End If
Next Cell
End Sub
Function GetMaxRowIndex(ByVal myWorkSheet As Worksheet) As Long
Dim numberofRowsInColumnC As Long
numberofRowsInColumnC = myWorkSheet.Cells(Rows.Count, "C").End(xlUp).Row
Dim numberofRowsInColumnD As Long
numberofRowsInColumnD = myWorkSheet.Cells(Rows.Count, "D").End(xlUp).Row
Dim numberofRowsInColumnE As Long
numberofRowsInColumnE = myWorkSheet.Cells(Rows.Count, "E").End(xlUp).Row
Dim numberofRowsInColumnF As Long
numberofRowsInColumnF = myWorkSheet.Cells(Rows.Count, "F").End(xlUp).Row
Dim maxNumberOfRows As Long
maxNumberOfRows = WorksheetFunction.Max(numberofRowsInColumnC, _
numberofRowsInColumnD, _
numberofRowsInColumnE, _
numberofRowsInColumnF _
)
GetMaxRowIndex = maxNumberOfRows
End Function
I am trying to bring a formula inside my vba code and I am getting an error inside it. Please have a look into the code and kindly share your thoughts.
This is my excel function that was written in VBA Code :
GetUniqueCount(Range,Value)
And here is the VBA Code trying to make use of it :
Sheets("sheet2").Activate
With ThisWorkbook.Sheets("sheet2").UsedRange
lastrow = .Rows(.Rows.Count).Row
End With
For i = 14 To lastrow
check = Range("h" & i).Value
If check <> "" Then
Range("I" & i).Value = WorksheetFunction.GetUniqueCount(sheet1!.Range("A1:B100"), check)
Else
Range("I" & i).Value = ""
Next
The range for the function comes from a different sheet. How do I write it in VBA?
This is the function for it :
Function GetUniqueCount(Rng1 As Range, Lookup As String) As Long
Dim x, dict
Dim i As Long, cnt As Long
Set dict = CreateObject("Scripting.Dictionary")
x = Rng1.Value
For i = 1 To UBound(x, 1)
If x(i, 1) = Lookup Then
dict.Item(x(i, 1) & x(i, 2)) = ""
End If
Next i
GetUniqueCount = dict.Count
End Function
You have other possible errors in your code, unqualified Range, etc.
Since your Function GetUniqueCount is not Excel's built in WorksheetFunction, but your own UDF, you don't need to call it with WorksheetFunction.GetUniqueCount but just GetUniqueCount.
Try the code below:
Option Explicit
Sub Test()
Dim LastRow As Long, i As Long
Dim check As String
With ThisWorkbook.Worksheets("sheet2")
LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
Dim Rng As Range
Set Rng = Worksheets("sheet1").Range("A1:B100")
For i = 14 To LastRow
check = .Range("H" & i).Value
If check <> "" Then
.Range("I" & i).Value = GetUniqueCount(Rng, check)
Else
.Range("I" & i).Value = ""
End If
Next i
End With
End Sub
There is no worksheet function by the name of GetUniqueCount. If this is a function you have in your code then the way to call it would be like this:-
Range("I" & i).Value = GetUniqueCount("Sheet1".Range("A1:B100"), check)
This code presumes that your function is either on the same code sheet as the calling procedure or declared public. It must take two arguments, the first of which must be a range, the second of the same data type as check. If you didn't declare check (which isn't a good idea) then its data type will be Variant.
I am copying information from one workbook to another. The code I have so far works great if every column has data. It does not work when I am trying to repeatedly copy information from column A and B of worksheet(supplementary expenses) to worksheet(expenses) and column B is blank. As the next time the sub is run and Column B does have values they are placed in the next blank cell, not the cell that is correlated to column A.
Here is the code I have so far:
Sub SupplementaryExpenses()
Dim x As Workbook
Dim y As Workbook
Set y = Workbooks.Open("File Path")
Set x = Workbooks.Open("File Path")
x.Sheets("b.1 Supplementary expenses").Range("a9", Range("a9").End(xlDown)).Copy
y.Sheets("Expenses").Range("a1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
x.Sheets("b.1 Supplementary expenses").Range("b9", Range("b9").End(xlDown)).Copy
y.Sheets("Expenses").Range("b1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
x.Sheets("b.1 Supplementary expenses").Range("c9", Range("c9").End(xlDown)).Copy
y.Sheets("Expenses").Range("c1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Also any time this sub is run it would be helpful if there were someway to fill column L with the flag 201601 and then change to 201602 when I bring in the next months data.
Try this:
Sub SupplementaryExpenses()
Dim x As Workbook
Dim y As Workbook
Dim lastrow As Long
Dim tRow as long
Set y = Workbooks.Open("File Path")
Set x = Workbooks.Open("File Path")
With x.Sheets("b.1 Supplementary expenses")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
tRow = y.Sheets("Expenses").Range("a1").End(xlDown).Offset(1, 0).Row
y.Sheets("Expenses").Range("A" & trow).Resize(lastrow - 8, 3).Value = .Range(.Cells(9, 1), .Cells(lastrow, 3)).Value
y.Sheets("Expenses").Range("D" & trow).Resize(lastrow - 8, 1).Value = .Range(.Cells(9, 8), .Cells(lastrow, 8)).Value
End With
End Sub
It will take all of the three columns at once and assign the values to the new area. It will not care about blanks in column B or C.
This should be faster than copy/paste as you only want the values.
Get the last used row and change out your range statements similar to this:
Dim LastRow
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
x.Sheets("b.1 Supplementary expenses").Range(Cells(9, 1), Cells(LastRow, a)).Copy 'this is R1C1 format meaning row then column
You can use this for filling a column
If you put it after the rest of your code and ensure that you have the sheet you want column L populated with active:
sDate = Format(Date, "yyyymm")
For i = 2 To LastRow' you may need to grab this anew if you added lines
If Cells(i, "L") = vbNullString Then 'ensures that there isn't anything in the cell
Cells(i, "L").value = sDate
End If
Next
I need your help with conditional Vlookup. I found a code that works fine if there is vlookup value in the source data but it fails once there is a missing value. Also I need to add a condition ('If the value is found by Lookup, then return "Old" (from 2nd column in vlookup table)
'If the value is NOT found, then return "New" (just text which is not coming from vlookup table). Could you help me?
Thank you,'Russ
Sub Vlookup_Condition()
Dim rng As Range
Dim i As Long
With ActiveSheet.Cells
Set rng = .Range("A1:A" & .Cells(.Rows.count, 1).End(xlUp).row)
For i = 2 To rng.Rows.count
'If the value is found by Lookup, then return "Old" (from 2nd column in vlookup table)
'If the value is NOT found, then return "New" (just text which is not coming from vlookup
'table)
rng.Cells(i, 2) = Application.WorksheetFunction.VLookup(.Cells(i, 1), Sheets("Lookuptable").Range("A:B"), 2, False)
Next
End With
End Sub
As per your puzzle. I found a solution like this Russ
UPDATED & TESTED
Sub Vlookup_Condition()
Dim rng As Range
Dim i As Long
Application.ScreenUpdating = False
Worksheets("DataFile").Activate
Range("R2").Activate
With Worksheets("DataFile").Cells
Set rng = .Range("O1:O" & .Cells(.Rows.count, 1).End(xlUp).row)
For i = 2 To rng.Rows.count
rng.Cells(i, 4) = Application.VLookup(.Cells(i, 15), Sheets("Lookuptable").Range("A:B"), 2, False)
If IsError(rng.Cells(i, 4)) Then
If rng.Cells(i, 4) = CVErr(xlErrNA) Then ' Given if condition to change it from "#NA" to "New"
rng.Cells(i, 4) = "New"
End If
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Try this
Sub Vlookup_Condition()
Dim rng As Range
Dim ws as Worksheet
Dim i As Long
Set ws = ActiveSheet
i =2
With ws.Range("A1:A" & Rows.Count)
.Formula = "=VLookup(" & ws.Cells(2,1).Address & ",Lookuptable!$A:$B,2,false)"
End With
Do while ws.Cells(i, 1) <> ""
if ws.Cells(i,2) <> "OLD" Then ws.Cells(i,2) = "New"
i = i +1
Loop
Hope this helps there is a more concise way to do this but this way might be easier to build off of.
Ok after further review TRY THIS! lol
With ActiveSheet
Set rng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
For i = 2 to rng.Rows.Count
rng.Cells(i, 2) = Application.WorksheetFunction.VLookup(ActiveSheet.Cells(i,1), Sheets("Lookuptable").Range("A:B"), 2, False)
Next
End With
End Sub
I really hope this works for ya mate if not ill probably not do any actual work AT work tomorrow until i figure out how i totally punted this help lol