Look up values in sheet(x) column(x), match to values in sheet(y) column(y), if they match paste row - vba

Dealing with an issue that seems simple enough, but for some reason I cannot get this to work.
I have a data input sheet I am trying to match values across to another sheet, the values are both in column E, and all the values in column E are unique.
The values will always be stored in rows 8 though to 2500.
My code is as below, however is throwing the ever useful 1004 error (Application-Defined or object-defined error), on line
If Sheets("Target Inputs").Range("E" & CStr(LSearchRow)).Value = searchTerm Then
any help would be greatly appreciated:
Sub LOAD_BUID_Lookup()
Dim i As Integer
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim searchTerm As String
On Error GoTo Err_Execute
For i = 8 To 2500
searchTerm = Range("E" & i).Text
If Sheets("Target Inputs").Range("E" & CStr(LSearchRow)).Value = searchTerm Then
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("LOAD").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Target Inputs").Select
End If
Next i
Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub

LSearchRow is not being set to any value, which means it is 0. This in turn throws the exception, since the row number cannot be 0. And there is no reason whatsoever to convert to string with CStr, since the concatenation casts the entire range parameter to a string anyway.

Usually when comparing two different columns in two different sheet you would see a double loop the first to loop through sheet1 and the second to take every value of sheet1 and loop through sheet2 to find a match. In reading your description I think this is what you want.
Double loops can be time intensive. There is another way, Worksheetfunction.match!!
I also noticed your code selecting/activating sheets multiple times. Typically selecting/activating sheets is not required if you declare and instantiate the variables you need.
Below is an example code I tried to make it as plug and play as possible, but I wasn't sure of the name of the sheet you are looping through. I've tested the code on dummy data and it seems to work, but again I'm not quite positive on the application. I've commented the code to explain as much of the process as possible. Hopefully it helps. Cheers!
Option Explicit 'keeps simple errors from happening
Sub LOAD_BUID_Lookup()
'Declare variables
Dim wb As Workbook
Dim wsInputs As Worksheet
Dim wsTarget As Worksheet
Dim wsLoad As Worksheet
Dim searchTerm As String
Dim matchRng As Range
Dim res
Dim i As Integer
'instantiate variables
Set wb = Application.ThisWorkbook
Set wsInputs = wb.Worksheets("Inputs") 'unsure of the name of this sheet
Set wsTarget = wb.Worksheets("Target Inputs")
Set wsLoad = wb.Worksheets("LOAD")
Set matchRng = wsTarget.Range("E:E")
On Error GoTo Err_Execute
For i = 8 To 2500
searchTerm = wsInputs.Range("E" & i).Text 'can use sheet variable to refer exactly to the sheet you want without selecting
'get match if one exists
On Error Resume Next
res = Application.WorksheetFunction.Match(searchTerm, matchRng, 0) 'will return a row number if there is a match
If Err.Number > 0 Then 'the above command will throw an error if there is no match
'MsgBox "No Match!", vbCritical
Err.Clear ' we clear the error for next time around
On Error GoTo 0 'return to previous error handeling
Else
On Error GoTo 0 'return to previous error handeling
wsInputs.Range("A" & i).EntireRow.Copy Destination:=wsLoad.Range("A" & wsLoad.Range("E50000").End(xlUp).Row + 1) 'gets last row and comes up to last used row ... offset goes one down from that to the next empty row
End If
Next i
'Application.CutCopyMode = False -- there is no need for this when we use "Destination"
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub

Related

How to append address of current cell to range object

I've been trying to write a function that goes through an Excel worksheet to find a range of cells fulfilling a certain condition (two cells in the same row that have to be equal).
I've written the following code that goes through the Worksheet row by row and checks if the condition is fulfilled.
If a cell is found for which the condition is true I would like the address of the cell to be added to a range.
The output of the function should finally be this range which is subsequently used to populate a dropdown menu in a dialog with the entries fulfilling the condition.
Private Function DetermineRange(WorksheetName As String, Column1 As Integer, Column2 As Integer) As Range
Dim rng As Range
'Go through rows of specified worksheet
For currRow = 1 To Worksheets(WorksheetName).Cells(Rows.Count, 3).End(xlUp).Row
'Compare cells in specified columns of current row
If Worksheets(WorksheetName).Cells(currRow, Column1).Value = Worksheets(WorksheetName).Cells(currRow, Column2).Value _
And Not (Worksheets(WorksheetName).Cells(currRow, Column1).Value = "") Then
'If cells are equal, but not empty, append current adress of current cell to range
If Not rng Is Nothing Then
Set rng = Union(rng, Worksheets(WorksheetName).Cells(currRow, 2))
Else
Set rng = Worksheets(WorksheetName).Cells(currRow, 2)
End If
End If
Next currRow
If Not rng Is Nothing Then
'return found Range
Set DetermineRange = rng
MsgBox ("Range is: " & rng)
Else
'DEBUG: Throw error message if rng is empty,
MsgBox ("DEBUG DetermineRange Function:" & vbCrLf & _
"Error! No corresponding Cells found in Sheet" & WorksheetName)
End If
End Function
Cycling through the rows works fine, however I don't seem to be able to add the addresses for the cells after the condition is checked to the range object.
I have also tried the following, which results in a
Runtime error 424: Object required
'If cells are equal, but not empty, append current address of current cell to range
If Not rng Is Nothing Then
Set rng = Union(rng, Worksheets(WorksheetName).Cells(currRow, 2).Address)
Else
Set rng = Worksheets(WorksheetName).Cells(currRow, 2).Address
End If
I've been looking around, but can't seem to find much information on how to add cells to range objects however...
Maybe one of you could help! Any kind of pointer in the right direction is highly appreciated!
Thanks in advance for any kind of help!
Edit:
I am calling the function like this:
Set NameRng = DetermineRange("Features", ProjectColumn, TCGroupColumn)
cb_FcnName.RowSource = Worksheets(3).Name & "!" & NameRng.Address
But I get the following error:
Runtime Error 380: Not able to set property RowSource
One method is to capture the cell addresses. Concatenate these and use the final value to build a new range.
Example:
Public Function DetermineRange(WorksheetName As String, Column1 As Integer, Column2 As Integer) As Range
Dim rng As Range
Dim currRow As Integer
Dim targetSheet As workSheet ' Shortcut to requested sheet.
Dim matchesFound As String ' Address of matching cells.
' This line will raise an error if the name is not valid.
Set targetSheet = ThisWorkbook.Sheets(WorksheetName)
'Go through rows of specified worksheet
For currRow = 1 To targetSheet.UsedRange.Rows(targetSheet.UsedRange.Rows.Count).Row
'Compare cells in specified columns of current row
If targetSheet.Cells(currRow, Column1).Value <> "" Then
If targetSheet.Cells(currRow, Column1).Value = targetSheet.Cells(currRow, Column2).Value Then
' Capture address of matching cells.
If Len(matchesFound) > 0 Then
matchesFound = matchesFound & "," & targetSheet.Cells(currRow, Column1).Address
Else
matchesFound = targetSheet.Cells(currRow, Column1).Address
End If
End If
End If
Next currRow
' DEBUG: Throw error message if no matches found.
If Len(matchesFound) = 0 Then
Err.Raise vbObjectError + 101, "DetermineRange", "No matching cells found."
End If
' Return range.
Set DetermineRange = targetSheet.Range(matchesFound)
End Function
The code is a little rough and ready. I can't help but feel there are few too many lines. But the basic approach works.

Search for specific string in an Excel Workbook

So, I need to make an Excel Macro in VBA that will search for a string, then compare it with a pre-set string of my choice and then change the value of a cell in another Sheet.
It goes like this:
Sub Macro1()
Dim A As Integer
Dim WS As Worksheet
Dim ToCompare, Coniburo As String
Coniburo = "My String"
For Each WS In Worksheets
For A = 1 To Rows.Count
ToCompare = Left(Cells(A, 3), 100)
If InStr(ToCompare, Coniburo) > 0 Then
Sheets("Last Sheet").Cells(21, 2).Value = "233"
End If
Next A
Next
The macro works....... If I remove the first For (the one that search through sheets) and as long as I'm in a sheet where "My string" is present. Otherwise, it doesn't work. It takes a long time to process, over a minute since there are 17 sheets.
Why isn't working? I read a lot of posts here, the Microsoft Dev forum, a site called Tech on the Net, and still there is something I'm missing, but I don't know why.
Can anybody point me in the right direction?
Use a With ... End With to focus the parent worksheet for each iteration of the loop.
Option Explicit
Sub Macro1()
Dim a As Long, Coniburo As String, ws As Worksheet
Coniburo = "My String"
For Each ws In Worksheets
With ws
For a = 1 To .Cells(.Rows.Count, "C").End(xlUp).Row
If CBool(InStr(Left(.Cells(a, 3), 100), Coniburo, vbTextCompare)) Then
Worksheets("Last Sheet").Cells(21, 2).Value = 233
End If
Next a
End With
Next
End Sub
You need to prefix Rows, Range and Cells calls with a period like .Rows... or .Range(...) or .Cells(...) when inside a With ... End With block. This identifies them with the parent worksheet described by the With .. End With.
I also made the comparison case-insensitive with vbTextCompare.
There is the remaining problem of writing and rewriting 233 into the same cell on the same worksheet but that is another matter.
I've bent the rules a little here but I want to show how we could use the built in FIND function to speed things up dramatically. Simply, we'll work through each sheet within column C only; we'll use the FIND function to find the ROW number where column C contains your search string.... then we'll double-check that cell to see if your search string is within the first 100 characters, per your requirement. If it is, we'll consider that a match. In addition to your result of logging "233" into the sheet "Last Page" I've included some bright green highlighting just to help see what's going on...
Sub findConiburo()
Coniburo = "My String"
For Each ws In Worksheets
With ws.Range("C:C")
myName = ws.Name 'useful for debugging
queue = 1 'will be used to queue the FIND function
x = 0 'loop counter
Do 'loop to find multiple results per sheet
On Error Resume Next 'Disable error handling
'FIND Coniburo within ws column C, log row number:
'Note ".Cells(queue, 1)" is a relative reference to the current WS, column C
foundRow = .Find(What:=Coniburo, After:=.Cells(queue, 1), LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Row
'If no result found then an error number is stored. Perform error handling:
If Err.Number <> 0 Then
'No results found, don't do anything, exit DO to skip to next sheet:
Exit Do
End If
On Error GoTo 0 'Re-enable error handling
If x = 0 Then
'first loop - log the first row result:
originalFoundRow = foundRow
ElseIf foundRow = originalFoundRow Then
'Not the first loop. Same result as original loop = we're back at the start, so exit loop:
Exit Do
End If
'Update queue so next loop will search AFTER the previous result:
queue = foundRow
'check if the string is not only SOMEWHERE in the cell,
'but specifically within the first 100 characters:
ToCompare = Left(.Cells(foundRow, 1), 100)
If InStr(ToCompare, Coniburo) > 0 Then
.Cells(foundRow, 1).Interior.ColorIndex = 4 'highlight green
Sheets("Last Sheet").Cells(21, 2).Value = "233"
End If
'Update loop counter:
x = x + 1
Loop
End With
Next ws
End Sub

Need to change a macro so that it transposes and fills rows instread of columns

I am running a macro that copies, finds next available column along and then pastes as values.
After reluctantly continuing to do it in columns I have realized how much it easier it will be to have it vertically stored - data is pulled in every hour so having it in columns is making summarizing a lot of effort.
The macro below finds the next available column and then pastes next to it. I have tried to change it so that it will transpose paste with the date alongside the row in column A for example, but I am struggling to work it out.
Any help would be appreciated thanks a lot.
Sub HistoricalDataNewOne()
Dim TargetSht As Worksheet, SourceSht As Worksheet, SourceCol As Integer, SourceCells As Range
'If an error occurs skip code to the Err-Hanlder line and the display the error message.
On Error GoTo Err_Handler
'This is the sheet where your copy information from. Change "Sheet1" to the name of your soure sheet
Set SourceSht = ThisWorkbook.Sheets("BARGE LIVE TRACKING")
'Name of the sheet where data is to be copied to. Rename Sheet2 to the name of your target sheet
Set TargetSht = ThisWorkbook.Sheets("Detailed Tracking")
'This is the cells you will copy data from. This is targeting cells B1 to the last used cell in column B
Set SourceCells = SourceSht.Range("g3:h" & SourceSht.Range("J65536").End(xlUp).Row)
'This is finding the next column available in the target sheet. It assumes dates will be in row 1 and data in row 2 down
If TargetSht.Range("A1").Value = "" Then
'Cell A1 is blank so the column to put data in will be column #1 (ie A)
SourceCol = 1
ElseIf TargetSht.Range("IV1").Value <> "" Then
'Cell IV1 has something in it so we have reached the maximum number of columns we can use in this sheet.
'Dont paste the data but advise'
MsgBox "There are no more columns available in the sheet " & TargetSht.Name, vbCritical, "No More Data Can Be Copied"
'stop the macro at this point
Exit Sub
Else
'cell A1 does have data and we havent reached the last column yet so find the next available column
SourceCol = TargetSht.Range("IV1").End(xlToLeft).Column + 2
End If
'Put in the date in the appropriate column in row 1 of the target sheet
TargetSht.Cells(1, SourceCol).Value = Format(Now, "HH:MM DD/MMM")
'We can now start copying data. This will copy the cells in column B from the source sheet to row 2+ in the target sheet
SourceCells.Copy
TargetSht.Cells(2, SourceCol).PasteSpecial xlPasteValues
Exit Sub 'This is to stop the procedure so we dont display the error message every time.
Err_Handler:
MsgBox "The following error occured:" & vbLf & "Error #: " & Err.Number & vbLf & "Description: " & Err.Description, _
vbCritical, "An Error Has Occured", Err.HelpFile, Err.HelpContext
End Sub
These amendments to the last part should do:
Sub HistoricalDataNewOne()
Dim TargetSht As Worksheet, SourceSht As Worksheet, SourceCells As Range
'If an error occurs skip code to the Err-Hanlder line and the display the error message.
On Error GoTo Err_Handler
'This is the sheet where your copy information from. Change "Sheet1" to the name of your soure sheet
Set SourceSht = ThisWorkbook.Sheets("BARGE LIVE TRACKING")
'Name of the sheet where data is to be copied to. Rename Sheet2 to the name of your target sheet
Set TargetSht = ThisWorkbook.Sheets("Detailed Tracking")
'This is the cells you will copy data from. This is targeting cells B1 to the last used cell in column B
Set SourceCells = SourceSht.Range("g3:h" & SourceSht.Range("J65536").End(xlUp).Row)
''''''''''''''''''''''''''''''
' No changes so far
' Now the changes:
''''''''''''''''''''''''''''''
Dim dstRow As Long: dstRow = TargetSht.Range("A1000000").End(xlUp).Row + 2
'Put in the date in the appropriate row columns A 1 of the target sheet
TargetSht.Cells(dstRow, 1).Value = Format(Now, "HH:MM DD/MMM")
TargetSht.Cells(dstRow, 2).Resize(SourceCells.Columns.Count, SourceCells.Rows.Count).Value2 = _
Application.Transpose(SourceCells.Value2)
Exit Sub 'This is to stop the procedure so we dont display the error message every time.
Err_Handler:
MsgBox "The following error occured:" & vbLf & "Error #: " & Err.Number & vbLf & "Description: " & Err.Description, _
vbCritical, "An Error Has Occured", Err.HelpFile, Err.HelpContext
End Sub

Excel VBA delete entire row if cell in column D is empty

Can anyone walk me through how to write a script to delete the entire row if a cell in column D = "" on sheet 3 in range D13:D40.
Also, how to prevent the user from accidentally running the script again once those cells in the range are already deleted and other cells are now on the D13:D40 range?
Solution: This is working for me:
Sub DeleteRowsWithEmptyColumnDCell()
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.ActiveSheet.Range("D13:D40")
With rng
' Loop through all cells of the range
' Loop backwards, hence the "Step -1"
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
' Since cell is empty, delete the whole row
.Item(i).EntireRow.Delete
End If
Next i
End With
End Sub
Explanation: Run a for loop through all cells in your Range in column D and delete the entire row if the cell value is empty. Important: When looping through rows and deleting some of them based on their content, you need to loop backwards, not forward. If you go forward and you delete a row, all subsequent rows get a different row number (-1). And if you have two empty cells next to each other, only the row of the first one will be deleted because the second one is moved one row up but the loop will continue at the next line.
No need for loops:
Sub SO()
Static alreadyRan As Integer
restart:
If Not CBool(alreadyRan) Then
With Sheets("Sheet3")
With .Range("D13:D40")
.AutoFilter 1, "="
With .SpecialCells(xlCellTypeVisible)
If .Areas.Count > 1 Then
.EntireRow.Delete
alreadyRan = alreadyRan + 1
End If
End With
End With
.AutoFilterMode = False
End With
Else
If MsgBox("procedure has already been run, do you wish to continue anyway?", vbYesNo) = vbYes Then
alreadyRan = 0
GoTo restart:
End If
End If
End Sub
Use AutoFilter to find blank cells, and then use SpecialCells to remove the results. Uses a Static variable to keep track of when the procedure has been run.
Here's my take on it. See the comments in the code for what happens along the way.
Sub deleterow()
' First declare the variables you are going to use in the sub
Dim i As Long, safety_net As Long
' Loop through the row-numbers you want to change.
For i = 13 To 40 Step 1
' While the value in the cell we are currently examining = "", we delete the row we are on
' To avoid an infinite loop, we add a "safety-net", to ensure that we never loop more than 100 times
While Worksheets("Sheet3").Range("D" & CStr(i)).Value = "" And safety_net < 100
' Delete the row of the current cell we are examining
Worksheets("Sheet3").Range("D" & CStr(i)).EntireRow.Delete
' Increase the loop-counter
safety_net = safety_net + 1
Wend
' Reset the loop-counter
safety_net = 0
' Move back to the top of the loop, incrementing i by the value specified in step. Default value is 1.
Next i
End Sub
To prevent a user from running the code by accident, I'd probably just add Option Private Module at the top of the module, and password-protect the VBA-project, but then again it's not that easy to run it by accident in the first place.
This code executes via a button on the sheet that, once run, removes the button from the worksheet so it cannot be run again.
Sub DeleteBlanks()
Dim rw As Integer, buttonID As String
buttonID = Application.Caller
For rw = 40 To 13 Step -1
If Range("D" & rw) = "" Then
Range("D" & rw).EntireRow.Delete
End If
Next rw
ActiveSheet.Buttons(buttonID).Delete
End Sub
You'll need to add a button to your spreadsheet and assign the macro to it.
There is no need for loops or filters to find the blank cells in the specified Range. The Range.SpecialCells property can be used to find any blank cells in the Range coupled with the Range.EntireRow property to delete these. To preserve the run state, the code adds a Comment to the first cell in the range. This will preserve the run state even if the Workbook is closed (assuming that it has been saved).
Sub DeleteEmpty()
Dim ws As Excel.Worksheet
Set ws = ActiveSheet ' change this as is appropriate
Dim sourceRange As Excel.Range
Set sourceRange = ws.Range("d13:d40")
Dim cmnt As Excel.Comment
Set cmnt = sourceRange.Cells(1, 1).Comment
If Not cmnt Is Nothing Then
If cmnt.Text = "Deleted" Then
If MsgBox("Do you wish to continue with delete?", vbYesNo, "Already deleted!") = vbNo Then
Exit Sub
End If
End If
End If
Dim deletedThese As Excel.Range
On Error Resume Next
' the next line will throw an error if no blanks cells found
' hence the 'Resume Next'
Set deletedThese = sourceRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not deletedThese Is Nothing Then
deletedThese.EntireRow.Delete
End If
' for preserving run state
If cmnt Is Nothing Then Set cmnt = sourceRange.Cells(1, 1).AddComment
cmnt.Text "Deleted"
cmnt.Visible = False
End Sub
I've recently had to write something similar to this. I'm not sure that the code below is terribly professional, as it involves storing a value in cell J1 (obviously this can be changed), but it will do the job you require. I hope this helps:
Sub ColD()
Dim irow As long
Dim strCol As String
Sheets("sheet2").Activate
If Cells(1, 10) = "" Then
lrun = " Yesterday."
Else: lrun = Cells(1, 10)
End If
MsgBox "This script was last run: " & lrun & " Are you sure you wish to continue?", vbYesNo
If vbYes Then
For irow = 40 To 13 step -1
strCol = Cells(irow, 4).Value
If strCol = "" Then
Cells(irow, 4).EntireRow.Delete
End If
Next
lrun = Now()
Cells(1, 10) = lrun
Else: Exit Sub
End If
End Sub

Locating Cell Values in Excel VBA

Using: Excel 2007/Win 7
First, I created a subroutine to find the dynamic range of a worksheet called 'WIP':
Sub GetWIPRange()
Dim WIPrng1 As Range
Dim WIPrng2 As Range
Sheets("WIP").Activate
Set WIPrng1 = Cells.find("*", [a1], , , xlByRows, xlPrevious)
Set WIPrng2 = Cells.find("*", [a1], , , xlByColumns, xlPrevious)
If Not WIPrng1 Is Nothing Then
Set WIPrng3 = Range([a1], Cells(WIPrng1.Row, WIPrng2.Column))
Application.Goto WIPrng3
Else
MsgBox "sheet is blank", vbCritical
End If
End Sub
Now I want to find a given contract number within the range defined above:
Sub find()
Dim find As Long
find = Application.WorksheetFunction.Match("545499", Range(WIPrng3.Parent.Name & "!" & WIPrng3.Address), 0)
MsgBox "Found at row : " & find
End Sub
But the error I get from the code above is:
Run-time error '91':
Object variable With block variable not set.
How can I fix this code so that it returns the row number of the value I'm seeking?
Is there a more efficient way of finding cell values using VBA? For example, if I have many worksheets and I want to search all worksheets and return a value's specific row number and worksheet location.
Many thanks!
Where is WIPrng3 defined? Is it defined as Public? The problem is that WIPrng3 has gone out of scope by the time you run "find" and is therefore Nothing. You can check for Nothing in your "find" code and run the Get procedure if needed. Like this
Sub find()
Dim find As Long
If WIPrng3 Is Nothing Then GetWIPRange
find = Application.WorksheetFunction.Match("545499", Range(WIPrng3.Parent.Name & "!" & WIPrng3.Columns(1).Address), 0)
MsgBox "Found at row : " & find
End Sub
Two things to note: If WIPrng3 returns a multicolumn range, MATCH will fail with a 1004 error. MATCH only works on a single column or row. In the example above, I restricted WIPrng3 to the first column in the MATCH function to avoid this. You didn't have this in your code.
Another thing is that you're looking for the text string "545499", not the number 545499. If your range contains the number and not the string, you'll get an error. You can trap that error with an On Error statement and handle appropriately.
Finally, I don't see the advantage to defining WIPrng3 (but I can't see the whole of what you're doing). You could easily use
Sub Find2()
Dim lRow As Long
On Error Resume Next
lRow = Application.WorksheetFunction.Match("545499", Sheets("WIP").UsedRange.Columns(1), 0)
If lRow > 0 Then
'add where the used range starts in case it's not row 1
MsgBox "Found at row : " & lRow + Sheets("WIP").UsedRange.Cells(1).Row - 1
Else
MsgBox "Not found"
End If
End Sub
You might end up looking through a larger range, but it won't appreciably affect performance.
I added the On Error in this example so you could see how it works. Don't put the On Error in there until you've tested it because it will mask all the other errors.
Charles Williams did some nice analysis on finding efficiency here http://fastexcel.wordpress.com/2011/10/26/match-vs-find-vs-variant-array-vba-performance-shootout/